diff options
| author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:26 -0800 |
|---|---|---|
| committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:26 -0800 |
| commit | deda2c0fd8689349fea2a900199a76ff7ecb319e (patch) | |
| tree | c9726d54a0806a9b0c75e6c82db8692aea0053cf /hobbit.scm | |
| parent | 3278b75942bdbe706f7a0fba87729bb1e935b68b (diff) | |
| download | scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.tar.gz scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.zip | |
Import Upstream version 5d6upstream/5d6
Diffstat (limited to 'hobbit.scm')
| -rw-r--r-- | hobbit.scm | 6981 |
1 files changed, 6981 insertions, 0 deletions
diff --git a/hobbit.scm b/hobbit.scm new file mode 100644 index 0000000..80d9d31 --- /dev/null +++ b/hobbit.scm @@ -0,0 +1,6981 @@ +;====================================================================
+;
+; HOBBIT: an optimizing scheme -> C compiler for SCM
+;
+; scm5d6
+; 2002-04-11
+;
+; Copyright (C) 1992-1997: Tanel Tammet
+; Copyright (C) 1998-2002: Free Software Foundation
+;
+; tammet@staff.ttu.ee, tammet@cs.chalmers.se
+;
+; Tanel Tammet
+; Department of Computer Science
+; Tallinn University of Technology
+; Raja 15
+; 12618, Tallinn
+; Estonia
+;
+; Department of Computing Science
+; Chalmers University of Technology
+; University of Go"teborg
+; S-41296 Go"teborg
+; Sweden
+;
+;
+; Documentation is in the file hobbit.texi
+;
+; NB! the terms for usage, copying
+; and redistribution of hobbit are given in the file COPYING
+;
+;
+; 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 1, 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, USA.
+;====================================================================
+;
+; Last part of changelog:
+;
+; april 2-11, 2002, Tanel Tammet:
+; - "system" and "verbose" compilation corrected
+; (system was previously not compiled, verbose is compiled to prolixity)
+; - "require" moved from top level to hobbit procedure (necessary
+; for self-compilation)
+; - "copy-tree" and "acons" compilation introduced
+; pre-april, 2002, Aubrey Jaffer:
+; - numerous changes necessary for co-operation with SCM5d5
+;
+;=================================================================
+;
+; default compiler options
+; (may be changed)
+;
+;=================================================================
+
+
+;;; The following variable controls whether hobbit will do any
+;;; macroexpansion. In that case (require 'defmacroexpand) must
+;;; be able to load the macroexpander from the scheme library.
+
+(define *expand-macros-flag* #t)
+
+;;; The following variable controls whether functions declared
+;;; to be inlined are inlined in full or only once. If the set of
+;;; nested inlinable function defs contains a circularity, the
+;;; setting #t will cause Hobbit to go into an infinite loop.
+
+(define *full-inlining-flag* #t)
+
+;;; The following variable controls whether any intermediate files
+;;; will be built. In that case (require 'pretty-print) and
+;;; (require 'pprint-load) must be able to load the prettyprinter
+;;; from the scheme library.
+
+(define *build-intermediate-files* #f)
+
+;;; The following variable controls whether any information about
+;;; compilation (except warnings and error messages) are printed.
+
+(define *infomessages-flag* #t)
+
+;;; The following variables control whether all map-s and for-each-s
+;;; are converted into inline-do-loops, or map-s and for-each-s
+;;; taking only one list are compiled as any other higher-order call
+;;; to functions map1 and for-each1 (inserted by the compiler in case
+;;; of need).
+
+(define *always-map->do-flag* #f)
+(define *always-for-each->do-flag* #f)
+
+
+;================================================================
+;
+; C-specific and system-specific options
+; (change if needed)
+;
+;===============================================================
+
+;;; If your C compiler does not assume that integers without a cast
+;;; are long ints, you may need to set the following flag to #t.
+;;; In that case all integers in the output C text, which should
+;;; be long ints, will have a trailing L cast.
+
+(define *long-cast-flag* #f)
+
+;;; If your C compiler may compile the C operator <test> ? <r1> : <r2>
+;;; to the code which may evaluate BOTH <r1> and <r2> in one
+;;; evaluation of the whole operator, you MUST define *lift-ifs-flag*
+;;; as #t.
+
+(define *lift-ifs-flag* #f)
+
+;;; If you C compiler may compile the C operator <a1> || <a2>
+;;; to the code which may evaluate <a2> even if <a1> evaluates to 1,
+;;; or, analogically, <a1> && <a2> may evaluate <a2> even if
+;;; <a1> evaluates to 0, you MUST define *lift-and-or-flag* as #t.
+
+(define *lift-and-or-flag* #f)
+
+;;; The following flag may be false only if the output C program
+;;; is supposed to run only on systems where the following holds:
+;;; ((-1%2 == -1) && (-1%-2 == -1) && (1%2 == 1) && (1%-2 == 1).
+;;; Otherwise the following flag must be #t.
+
+(define *badivsgns-flag* #f)
+
+;;; *input-file-modifier* and *output-file-modifier*
+;;; are strings which are given to the C file-opener to
+;;; indicate the mode of the file to be opened.
+;;; Select the MSDOS or ATARI version if appropriate, or define
+;;; your own modifier-strings.
+
+(define *input-file-modifier* "r") ;;; for UNIX & others
+(define *output-file-modifier* "w") ;;; for UNIX & others
+
+;;; (define *input-file-modifier* "rb") ;;; for MSDOS & ATARI
+;;; (define *output-file-modifier* "wb") ;;; for MSDOS & ATARI
+
+;;; The following variable controls the maximal length of auxiliary
+;;; functions created by the compiler (longer functions are split
+;;; into separate chunks).
+
+(define *max-auxfun-size* 50)
+
+;====================================================================
+;
+; Scheme-implementation-specific definitions. Change if needed.
+;
+;====================================================================
+
+(define (report-error . lst)
+ (display #\newline)
+ (display "COMPILATION ERROR: ")
+ (display #\newline)
+ (for-each display lst)
+ (display #\newline)
+ (abort))
+
+(define compile-allnumbers #t)
+
+;=================================================================
+;
+; renamable constants
+; (you might need to change some of these to
+; avoid name clashes)
+;
+;=================================================================
+
+
+;;; If your scheme file contains symbols which start
+;;; with a number, then *c-num-symb-prefix* is prefixed to
+;;; such symbols in the C source.
+
+(define *c-num-symb-prefix* "nonum_prefix_")
+
+;;; NB! If your scheme file contains variables which are also
+;;; C keywords or C functions defined in scm,
+;;; the string *c-keyword-postfix* is added to such variable names.
+;;; The list of prohibited variables is *c-keywords*. Add new
+;;; variables there, if needed.
+
+(define *c-keyword-postfix* "_nonkeyword")
+
+(define *c-keywords*
+ '(auto double int struct break else long switch
+ case enum register typedef char extern return union
+ const float short unsigned continue for signed void
+ default goto sizeof volatile do if static while
+
+;;; Some things are commented out to make hobbit compile itself correctly.
+
+ sizet void cell subr iproc smobfuns dblproc flo dbl isymnames s-and
+ s-begin s-case s-cond s-do s-if s-lambda s-let s-letstar s-letrec s-or
+ s-quote s-set i-dot i-quote i-quasiquote i-unquote i-uq-splicing
+ tcs-cons-imcar tcs-cons-nimcar tcs-cons-gloc tcs-closures tcs-subrs
+ tc7-asubr tcs-symbols tc7-ssymbol tcs-bignums tc16-bigpos tc3-cons
+ tc3-cons-gloc tc3-closure tc7-ssymbol tc7-msymbol tc7-string
+ tc7-vector tc7-bvect tc7-ivect tc7-uvect tc7-fvect tc7-dvect tc7-cvect
+ tc7-contin tc7-cclo tc7-asubr
+;;; tc7-subr-0 tc7-subr-1
+ tc7-cxr
+;;; tc7-subr-3 tc7-subr-2
+ tc7-subr-2x tc7-subr-1o tc7-subr-2o tc7-lsubr-2
+;;; tc7-lsubr
+ tc7-smob tc-free-cell tc16-flo tc-flo tc-dblr tc-dblc
+ tc16-bigpos tc16-bigneg tc16-port tc-inport tc-outport tc-ioport
+ tc-inpipe tc-outpipe smobfuns numsmob sys-protects cur-inp cur-outp
+ listofnull undefineds nullvect nullstr symhash progargs transcript
+ def-inp def-outp rootcont sys-protects upcase downcase symhash-dim
+ heap-size stack-start-ptr heap-org freelist gc-cells-collected
+ gc-malloc-collected gc-ports-collected cells-allocated linum
+ errjmp-ok ints-disabled sig-deferred alrm-deferred han-sig han-alrm
+ must-malloc ilength s-read s-write s-newline s-make-string
+ s-make-vector s-list s-string s-vector repl-driver newsmob lthrow repl
+ gc-end gc-start growth-mon iprin1 intprint iprlist lputc lputs
+ lfwrite time-in-msec my-time init-tables init-storage init-subrs
+ init-features init-iprocs init- init-scl init-io init-repl init-time
+ init-signals ignore-signals unignore-signals init-eval init-sc2
+ free-storage init-unif uvprin1 markcdr free0 warn wta everr sysintern
+;;; intern
+ sym2vcell makstr
+;;; make-subr
+;;; makfromstr
+ closure makprom force
+ makarb tryarb relarb ceval prolixity gc gc-for-newcell tryload cons2
+;;; acons
+ resizuve cons2r lnot booleanp eq equal consp cons nullp
+ setcar setcdr listp list length append reverse list-ref memq memv
+ member assq assv assoc symbolp symbol2string string2symbol numberp exactp
+ inexactp eqp lessp zerop positivep negativep oddp evenp lmax lmin sum
+ product difference lquotient absval remainder lremainder modulo lgcd llcm
+ number2string
+;;; string2number
+ makdbl istr2flo mkbig long2big dbl2big
+ iint2str iflo2str floprint bigprint big2dbl charp char-lessp chci-eq
+ chci-lessp char-alphap char-nump char-whitep char-upperp char-lowerp
+ char2int int2char char-upcase char-downcase stringp make-string
+ string st-length st-ref st-set st-equal stci-equal st-lessp
+ stci-lessp substring st-append vectorp make-vector
+ vector
+ vector-length vector-ref vector-set for-each procedurep apply map
+ call-cc copytree
+;;; eval
+ throwval quit input-portp output-portp
+ cur-input-port cur-output-port open-file open-pipe close-port
+ close-pipe lread read-char peek-char eof-objectp lwrite display
+ newline write-char file-position file-set-position lgetenv prog-args
+ makacro makmacro makmmacro
+ remove ash round array-ref array_ref
+ sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh sqrt expt
+ log abs exp
+ ;; verbose copy-tree @copy-tree
+ last-pair subml submr subfl ;from sc2.c
+))
+
+
+;;; NB! Your scheme file must not contain symbols which end with
+;;; the third elements of the following defines appended
+;;; with an integer. The same holds for the case where "-" is written
+;;; instead of "_". In case your scheme file contains any offending
+;;; symbols, replace them either in your file or replace the offending
+;;; strings in the following defines.
+;;;
+;;; E.g. it is not allowed to have symbols like: my__12, spec-tmp-var3,
+;;; foo-inst1, foo_inst5, bar-aux2.
+;;;
+;;; E.g. it is allowed to have symbols like: my__x, spec_tmp_var,
+;;; foo-inst1x, foo_inst_5, bar-aux-spec.
+
+(define *local-var-infix* "__")
+(define *new-var-name* "new_var")
+(define *tmp-var-name* "tmp_var")
+(define *new-parameter-prefix* "npar__")
+(define *new-fun-infix* "_aux")
+(define *new-letfun-infix* "_fn")
+(define *new-instfun-infix* "_inst")
+(define *new-constant-prefix* "const_")
+(define *closure-name-suffix* "_cl")
+(define *closure-vector-name* "clargsv_")
+
+;;; The following are names for the additional scheme functions
+;;; nonkeyword-make-promise and nonkeyword-force.
+;;; If your scheme file contains a function
+;;; with these names already, you must change the following names.
+
+(define *make-promise-function* 'nonkeyword_make-promise)
+(define *force-function* 'nonkeyword_force)
+
+;;; The following two will be names for the additional scheme functions
+;;; map1 and for-each1. If your scheme file contains any functions with
+;;; such names already, you must change the following names.
+
+(define *map1-function* 'map1)
+(define *for-each1-function* 'for-each1)
+
+;;; The following name is not allowed to occur in your scheme file,
+;;; neither is <name>_<nr> allowed.
+
+(define *new-closure-var* "newclosure")
+
+;;; The following is appended to symbols (not variables!) in your scheme
+;;; file. Thus your scheme file should not contain variables or symbols
+;;; ending with the value of *symbol-name-postfix*. If needed, change
+;;; *symbol-name-postfix* from "_symb" to some other string.
+
+(define *symbol-name-postfix* "_symb")
+
+;;; The following is appended to higher-order function names in your scheme
+;;; file which should be accessible from the interpreter. Thus your scheme
+;;; file should not contain variables or symbols
+;;; ending with the value of *export-hof-postfix*. If needed, change
+;;; *export-hof-postfix* from "_exporthof" to some other string.
+
+(define *export-hof-postfix* "_exporthof")
+
+;;; The following is needed for exportable functions which do not
+;;; have a type available in scm and need a special wrapper-function
+;;; to pass variables supplied by the interpreter. The wrapper function
+;;; name for some function foo is foo_wrapper, unless you change
+;;; the following define.
+
+(define *wrapper-postfix* "_wrapper")
+
+;;; The following is appended to those function names in your scheme
+;;; which are passed in the file to functions defined out of file
+;;; or to append: in other words, passed to interpreter
+
+(define *interpreter-suffix* "_interpreter")
+
+;;; The following is appended to names of stable vectors, to
+;;; denote the precalculated VELTS(x) part of a stable vector x.
+
+(define *st-vector-postfix* "_velts0")
+
+;;; The following is appended to names of closure procedures, giving
+;;; the C-only static SCM variable name
+
+(define *closure-proc-suffix* "_clproc0")
+
+;;; The following is a string which is prepended to the name of your
+;;; scheme file (without .scm) to form a name of a function generated
+;;; to initialize non-function defined variables in your scheme file.
+
+(define *init-globals-prefix* "init_globals_")
+
+;;; The following is a string which is prepended to the name of your
+;;; scheme file (without .scm) to form a name of a function generated
+;;; to perform all top-level computations in your scheme file.
+
+(define *top-actions-prefix* "top_actions_")
+
+;;; The following is a string which is prepended to the name of your
+;;; scheme file (without .scm) to form a name of a main initialization
+;;; function for your file.
+
+(define *init-fun-prefix* "init_")
+
+;;; The following is a string which is prepended to the name of your
+;;; scheme file (without .scm) to form a C variable which is generated
+;;; as a new global to gc-protect the constant nonimmediate objects
+;;; in your file.
+
+(define *protect-variable* "protect_constants_")
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of inlinable functions in your scheme file.
+
+(define *inline-declare* 'compile-inline)
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of inlinable variables in your scheme file.
+
+(define *inline-vars-declare* 'compile-inline-vars)
+
+;;; The following is a name of a variable which has to be defined to
+;;; make hobbit compile numeric procedures for all numbers as default,
+;;; not just integers:
+
+(define *allnumbers-declare* 'compile-allnumbers)
+
+;;; The following is a name of a variable which has to be defined to
+;;; make hobbit assume all procedures may be redefined.
+
+(define *all-funs-modified-declare* 'compile-all-proc-redefined)
+
+;;; The following is a name of a variable which has to be defined to
+;;; make hobbit assume all procedures may be redefined.
+
+(define *new-funs-modified-declare* 'compile-new-proc-redefined)
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of exportable functions in your scheme file.
+
+(define *export-declare* 'compile-export)
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of stable vector names (never-assigned except the first
+;;; initialization, not even by let or as local variables) in your
+;;; scheme file.
+
+(define *stable-vectors-declare* 'compile-stable-vectors)
+
+;;; The following is a name of a variable which may be defined to
+;;; the list of uninterned fast global vars (never holding nonimmediate values,
+;;; ie not char, bool or short int). These vars are NOT accessible
+;;; by the interpreter! They are used directly as C vars, without the GLOBAL
+;;; (ie * op) prefix.
+
+(define *fast-vars-declare* 'compile-uninterned-variables)
+
+;;; The following two are default names for the single argument
+;;; of the closure function and the variable which is assigned its
+;;; first element.
+
+(define *closurefun-arg* 'closurearg_0)
+(define *closurefun-arg-car* 'closurearg_car_0)
+
+;;; NB! The following determine the replacements for symbols
+;;; allowed in scheme variables but not in C variables.
+;;; Be careful with your scheme variables to avoid
+;;; name clashes! E.g. if you have scheme variables
+;;; bar--plus_, bar-+ and bar_+, they will all be converted to
+;;; the same C variable bar__plus_
+;;; In case of need feel free to change the replacement table.
+;;; You may also wish to change the scheme function
+;;; display-c-var, which performs the conversion.
+;;;
+;;; *global-postfix* determines the string to be appended to
+;;; variable names surrounded by *-s. The surrounding *-s
+;;; are dropped. E.g. *special-flag* will be converted to
+;;; special_flag_global
+;;; *char-replacements* determine the replacement strings
+;;; for characters not allowed in C variables. E.g. foo!?
+;;; will be converted to foo_excl__pred_
+
+(define *global-postfix* "_global")
+
+(define *char-replacements*
+ '((#\+ "_plus_")
+ (#\- "_")
+ (#\@ "_at_")
+ (#\. "_dot_")
+ (#\* "_star_")
+ (#\/ "_slash_")
+ (#\< "_less_")
+ (#\= "_equal_")
+ (#\> "_grtr_")
+ (#\! "_excl_")
+ (#\? "_pred_")
+ (#\: "_colon_")
+ (#\$ "_dollar_")
+ (#\% "_percent_")
+ (#\_ "_")
+ (#\& "_and_")
+ (#\~ "_tilde_")
+ (#\^ "_exp_")
+ (#\[ "_obrckt_")
+ (#\] "_cbrckt_")
+ (#\| "_vbar_")))
+
+;;; *c-indent* is the one-level indentation for C statements.
+;;; There is no indentation for C expressions.
+
+(define *c-indent* " ")
+
+;;; *c-infix-surround* is put before and after each infix C operator.
+;;; The sensible alternative to default "" is " " or #\space.
+
+(define *c-infix-surround* "")
+
+;;; The following are some obvious C constants. *c-null* is the
+;;; C object corresponding to scheme '().
+
+(define *c-true* 1)
+(define *c-false* 0)
+(define *c-null* "EOL")
+(define *scm-type* "SCM")
+(define *unspecified* '**unspecified**) ; you may change it
+
+;;; NB! Your scheme file must not contain any third symbols
+;;; of the following defines. If it does, replace the
+;;; offending symbol either in your file or in the following
+;;; defines (the compiler must contain the replacement anywhere
+;;; else).
+
+(define *function* '**function**)
+(define *higher-order-call* '**higher-order-call**)
+(define *higher-order-flag* #f)
+(define *dummy* '**dummy**)
+(define *not?* '**not?**)
+(define *and?* '**and**)
+(define *or?* '**or**)
+(define *open-file-function* '**open-file-function**)
+(define *set-current-input-port-function*
+ '**set-current-input-port-function**)
+(define *set-current-output-port-function*
+ '**set-current-output-port-function**)
+(define *num-s->c* '**num-s->c**)
+(define *num-c->s* '**num-c->s**)
+(define *bool-s->c* '**bool-s->c**)
+(define *bool-c->s* '**bool-c->s**)
+(define *char-c->s* '**char-c->s**)
+(define *float-c->s* '**float-c->s**)
+(define *tailrec* '**tailrec**)
+(define *c-fetch* '**c-fetch**)
+(define *c-adr* '**c-adr**)
+(define *op-if* '**op-if**)
+(define *op-begin* '**op-begin**)
+(define *op-let* '**op-let**)
+(define *do-not* '**do-not**)
+(define *return* '**return**) ; NB! do not change this!!!
+(define *goto-tailrec* '**goto-tailrec**)
+(define *mark-tailrec* '**mark-tailrec**)
+(define *define-constant* '**define-constant**)
+(define *actual-c-string* '**actual-c-string**)
+(define *actual-c-expr* '**actual-c-expr**)
+(define *actual-c-int* '**actual-c-int**)
+(define *actual-c-eval* '**actual-c-eval**)
+(define *special-pseudoquote* '**special-pseudoquote**)
+(define *global-access* '**global-access**)
+(define *sysapply* '**sysapply**)
+(define *listofnull* '**listofnull**)
+(define *velts-function* '**velts-function**)
+(define *st-vector-set* '**st-vector-set**)
+(define *st-vector-ref* '**st-vector-ref**)
+(define *make-cclo* '**make-cclo**)
+
+
+(define *special-scm->c-functions*
+ (list
+*function*
+*higher-order-call*
+*dummy*
+*not?*
+*and?*
+*or?*
+*open-file-function*
+*set-current-input-port-function*
+*set-current-output-port-function*
+*num-s->c*
+*num-c->s*
+*bool-s->c*
+*bool-c->s*
+*char-c->s*
+*float-c->s*
+*tailrec*
+*c-fetch*
+*c-adr*
+*op-if*
+*op-begin*
+*op-let*
+*do-not*
+*return*
+*goto-tailrec*
+*mark-tailrec*
+*define-constant*
+*actual-c-string*
+*actual-c-int*
+*actual-c-eval*
+*special-pseudoquote*
+*global-access*
+*listofnull*
+*velts-function*
+*st-vector-set*
+*st-vector-ref*
+*sysapply*
+*make-cclo*
+*unspecified*))
+
+
+;;; *intern-function* must be a C function taking a C string
+;;; and its length (C int) which builds a new scheme symbol
+;;; and returns it.
+;;; *makfromstr-function* must be a C function taking a C string
+;;; and its length (C int) which builds a new scheme string
+;;; and returns it.
+;;; *string->number-function* must be a C function taking a scheme string
+;;; and a radix (scheme int) which builds a new scheme number
+;;; and returns it.
+;;; Instead of using such special functions it is possible to
+;;; change the compiler functions make-symbol-constant and
+;;; make-string-constant instead.
+
+(define *intern-function* 'intern)
+(define *intern-symbol-function* 'intern)
+(define *makfromstr-function* 'makfromstr)
+(define *string->number-function* 'string2number)
+(define *c-eval-fun* 'eval)
+
+(define *internal-c-functions*
+ (list *intern-function* *makfromstr-function*
+ *intern-symbol-function* *string->number-function* *c-eval-fun*))
+
+(define *prohibited-funs* '())
+
+;;; *type-converters* is a list of scheme<->C representation
+;;; converters.
+
+(define *type-converters*
+ (list *num-s->c* *num-c->s* *bool-s->c* *bool-c->s*
+ *char-c->s* *float-c->s*))
+
+;;; The following four defines specify functions which will either
+;;; take or return (or both) C numbers or booleans. They
+;;; are actually set in set-primitive-tables.
+;;;
+;;; *num-arg-c-funs* is a set of scheme functions which will be
+;;; converted to analogous C functions (provided
+;;; *reckless-arithmetic* is #t) and which take C numbers
+;;; as arguments.
+;;; *num-res-c-funs* is a set of scheme functions which will
+;;; converted to analogous C functions (provided
+;;; *reckless-arithmetic* is #t) and which give C numbers
+;;; as results.
+;;; *bool-arg-c-funs* is a set of scheme functions which will always be
+;;; converted to analogous C functions
+;;; and which take C booleans (int 0 or non-0) as arguments.
+;;; *bool-res-c-funs* is a set of scheme functions which will be
+;;; converted to analogous C functions (some only if
+;;; *reckless-arithmetic* is #t) and which give C booleans
+;;; as results.
+
+(define *num-arg-c-funs* '())
+(define *always-num-arg-c-funs* '())
+(define *num-res-c-funs* '())
+(define *bool-arg-c-funs* '())
+(define *always-bool-res-c-funs* '())
+(define *bool-res-c-funs* '())
+
+;;; cxr-functions is a set of allowed cxr functions. You may
+;;; extend it if you wish.
+
+(define *cxr-funs*
+ '(car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
+
+;=================================================================
+;
+; global variable defs
+;
+;=================================================================
+
+;;; the following variable determines whether floats or ints are used
+
+(define *floats-flag* #f) ; must be #f in this version
+
+;;; The following variables control error-checking performed by
+;;; the resulting C program and numerical operations.
+
+(define *reckless-arithmetic-flag* #t) ; MUST be #t in this version
+(define *reckless-access-flag* #t) ; MUST be #t in this version
+
+;;; The following variable controls optimizations of integer
+;;; arithmetic for scheme<->C type conversions.
+
+(define *optimize-arithmetic* #f) ; MUST be #f in this version
+
+(define *splitted-init-function-names* '())
+(define *splitted-topaction-function-names* '())
+(define *map1-needed-flag* #f)
+(define *for-each1-needed-flag* #f)
+(define *inline-funs* '())
+(define *inline-vars* '())
+(define *top-actions-list* '())
+(define *inline-funs-data* '())
+(define *inline-vars-data* '())
+(define *c-port* '())
+(define *char-replacements-lists* '())
+(define *tmp-var-max* 500)
+(define *initial-defs* '())
+(define *passed-defs* '())
+(define *output-defs* '())
+(define *new-funs-list* '())
+(define *fun-arities-alist* '())
+(define *to-do-fun-list* '())
+(define *via-interpreter-defined* '())
+(define *non-directcomp-list* '())
+(define *current-fun-name* 'foo)
+(define *current-formal-args* '())
+(define *current-formal-argslist* '())
+(define *tailrec-flag* #f)
+(define *tmp-vars* '())
+(define *new-fun-nr* 0)
+(define *new-fun-names* '())
+(define *higher-ordr-flag* #f)
+(define *higher-order-args* '())
+(define *higher-order-funs* '())
+(define *higher-order-templates* '())
+(define *new-parameter-nr* '0)
+(define *make-new-ho-data* '())
+(define *dot-arg-funs* '())
+(define *dot-arg-templates* '())
+(define *new-instnr* '0)
+(define *new-primitive-instnr* '0)
+(define *local-vars* '())
+(define *new-constant-list* '())
+(define *symbol-constant-table* '())
+(define *interpreter-funname-table* '())
+(define *new-constant-num* 0)
+(define *passed-ho-dot-instfuns* '())
+(define *passed-closure-funs* '())
+(define *free-vars-list* '())
+(define *global-vars-list* '())
+(define *var-make-list* '())
+(define *symbol-list* '())
+(define *unknown-functions* '())
+(define *unknown-vars* '())
+(define *local-parameters* '())
+(define *top-level-funs* '())
+(define *export-functions* '())
+(define *export-table* '())
+(define *wrapper-table* '())
+(define *stable-vector-names* '())
+(define *fast-vars-list* '())
+(define *closure-var-vectornames* '())
+(define *lifted-closures-to-do* '())
+(define *lifted-trivial-closure-names* '())
+(define *lifted-closure-names* '())
+(define *liftable-hof-names* '())
+(define *non-liftable-hof-names* '())
+(define *special-c-vars* '())
+(define *closure-name-nr* 0)
+(define *closure-vector-name-nr* 0)
+(define *liftable-hof-database* '())
+(define *letrec-closure-nr* 0)
+(define *letrec-closures* '())
+(define *letrec-closure-init* '())
+(define *not-all-liftable-names* '())
+(define *all-funs-modified-flag* #f)
+(define *new-funs-modified-flag* #f)
+(define *primitives* '())
+(define *symbol-and-fun-list* '())
+(define *hobbit-declaration-vars* '())
+
+;;; the definition of force is used in case 'delay' is
+;;; found inside the program
+
+(define *force-definition*
+ (list
+ 'define
+ *force-function*
+ '(lambda (object) (object))))
+
+
+;;; the definition of make-promise is used in case 'delay' is
+;;; found inside the program
+
+(define *make-promise-definition*
+ (list
+ 'define
+ *make-promise-function*
+ '(lambda (proc)
+ (let ((result-ready? #f)
+ (result #f))
+ (lambda ()
+ (if result-ready?
+ result
+ (let ((x (proc)))
+ (if result-ready?
+ result
+ (begin (set! result-ready? #t)
+ (set! result x)
+ result)))))))))
+
+
+
+;;; a word of warning: the following two defs must not contain any
+;;; of the following: (cond, case, not, or, and, let, letrec, map, for-each)
+;;; and must not contain lambda-terms or clashing variables in let*.
+;;; There might be other analogous restrictions as well!
+
+(define *map1-definition*
+ (list 'define
+ *map1-function*
+ `(lambda (fn lst)
+ (let* ((res '()) (res-end res))
+ (do ()
+ ((,*not?* (pair? lst)) res)
+ (if (null? res)
+ (begin (set! res (cons (fn (car lst)) '()))
+ (set! res-end res))
+ (begin (set-cdr! res-end (cons (fn (car lst)) '()))
+ (set! res-end (cdr res-end))))
+ (set! lst (cdr lst)))))))
+
+
+(define *for-each1-definition*
+ (list 'define
+ *for-each1-function*
+ `(lambda (fn lst)
+ (do ()
+ ((,*not?* (pair? lst)) ,*unspecified*)
+ (fn (car lst))
+ (set! lst (cdr lst))))))
+
+;=================================================================
+;
+; top level
+;
+;=================================================================
+
+
+(define (Hobbit:compile file . files)
+ (hobbit (cons file files)))
+
+
+(define (hobbit file . files)
+ (let* ((tmpname "hobbit.tmp"))
+ (if *build-intermediate-files*
+ (begin (require 'pretty-print)))
+ (if *expand-macros-flag*
+ (begin (require 'defmacroexpand)
+ (require 'pprint-file)))
+ (if (not (memq 'hobbit *features*))
+ (set! *features* (cons 'hobbit *features*)))
+ (if (or (member '"scmhob.scm" (cons file files))
+ (member '"scmhob" (cons file files)))
+ (report-error "The file scmhob.scm is not allowed to be compiled!"))
+ (init-global)
+ ;; check for defmacros
+ (if *expand-macros-flag*
+ (if (not (find-if (lambda (x) (file-contains-defmacro? x))
+ (cons file files)))
+ (set! *expand-macros-flag* #f)))
+ (set! *initial-defs* '())
+ (if *expand-macros-flag* (for-each defmacro:load (cons file files)))
+ (for-each (lambda (x)
+ (if *infomessages-flag*
+ (begin (newline)
+ (display "Starting to read ") (display x)))
+ (read-compiled-file x tmpname))
+ (cons file files))
+ (if *infomessages-flag* (newline))
+ (compile-defs file (reverse *initial-defs*))))
+
+(define (file-contains-defmacro? str)
+ (let ((foundflag #f)
+ (expr '())
+ (port (if (file-exists? str)
+ (open-input-file str)
+ (if (file-exists? (string-append str ".scm"))
+ (open-input-file (string-append str ".scm"))
+ (report-error "Could not find file " str)))))
+ (if port
+ (do ()
+ ((or foundflag (eof-object? expr)) foundflag)
+ (set! foundflag (expr-contains-defmacro? expr))
+ (set! expr (read port)))
+ #f)))
+
+(define (expr-contains-defmacro? expr)
+ (cond ((not (pair? expr)) #f)
+ ((or (eq? 'quote (car expr)) (eq? 'quasiquote (car expr))) #f)
+ ((eq? 'defmacro (car expr)) #t)
+ (else (pair-find-if (lambda (x) (expr-contains-defmacro? x)) expr))))
+
+
+(define (read-compiled-file file tmpname)
+ (let* ((iport (if (file-exists? file)
+ (open-input-file file)
+ (if (file-exists? (string-append file ".scm"))
+ (open-input-file (string-append file ".scm"))
+ (report-error "Could not find file " file))))
+ (oport (if *expand-macros-flag* (open-output-file tmpname) '()))
+ (def #t))
+ (if *infomessages-flag* (newline))
+ (if *expand-macros-flag*
+ (begin
+ (if *infomessages-flag*
+ (begin
+ (display "Starting macroexpansion building the ")
+ (display "temporary file ")
+ (display tmpname) (display #\.) (newline)))
+ (pprint-filter-file iport defmacro:expand* oport)
+ (close-output-port oport)
+ (set! iport (open-input-file tmpname))))
+ (do ()
+ ((eof-object? def)
+ (close-input-port iport))
+ (set! def (read iport))
+ (cond ((eof-object? def))
+ ((and (pair? def)
+ (or (eq? 'load (car def))
+ (eq? 'require (car def))))
+ (report-warning "ignoring a load on top level: " def))
+ (else
+ (set! *initial-defs* (cons def *initial-defs*)))))))
+
+(define (compile-defs file deflst)
+ (let ()
+ (set! file (descmify file))
+ ;; - - - - adding primitives delay and force, if neccessary - - - - -
+ (if (find-if (lambda (x) (in-fun-position? 'delay x)) deflst)
+ (set! deflst
+ (append deflst
+ (append
+ (list *force-definition*)
+ (list *make-promise-definition*)))))
+ ;; - - - - - initial checks and flag-setting, sorting out the toplevel
+ ;; builds *top-level-names*, *modified-primitives* and
+ ;; *modified-top-level-names*:
+ (make-top-level-namelist! deflst)
+ ;; sorts out the toplevel:
+ (sort-out-toplevel! deflst file)
+ (if (not *floats-flag*)
+ (compute-floats-flag! deflst #t))
+ (if *infomessages-flag*
+ (if *floats-flag*
+ (begin
+ (display "Generic (slow) arithmetic assumed: ")
+ (display *floats-flag*)
+ (display " found.")
+ (newline))
+ (begin
+ (display "Bounded integer (fast) arithmetic assumed.")
+ (newline))))
+ (set-primitive-tables)
+ (set! *passed-defs* '())
+ ;; - - - - - vars-simplification pass - -
+ (set! *to-do-fun-list*
+ (map vars-simplify-wholedef *to-do-fun-list*))
+ ;; - - - - - finding liftable hof-s - - -
+ (set! *liftable-hof-names* '())
+ (set! *non-liftable-hof-names* '())
+ (for-each (lambda (x)
+ (if (and (pair? (caddr x))
+ (eq? 'lambda (caaddr x))
+ (liftable-hof? (caddr x) (cadr x)))
+ (set! *liftable-hof-names*
+ (cons (cadr x) *liftable-hof-names*))))
+ *to-do-fun-list*)
+ (for-each lift-analyse-def! *to-do-fun-list*)
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 1 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".anl"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *to-do-fun-list*)
+ (close-output-port fport)
+ (newline)
+ (display "analyzed & marked definitions file ")
+ (display (string-append file '".anl"))
+ (display " is built.")))
+ ;; initial analysis passes completed
+ ;; - - - - - building closures - - - - - - - -
+ (do ((part *to-do-fun-list* part))
+ ((null? part))
+ (set! *lifted-closures-to-do* '())
+ (set! *passed-defs*
+ (cons (try-closure-making-def(car part)) *passed-defs*))
+ (set! part (append *lifted-closures-to-do* (cdr part))))
+ (set! *to-do-fun-list* (reverse *passed-defs*))
+ (for-each lift-unmark-def! *to-do-fun-list*)
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 2 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".cls"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *to-do-fun-list*)
+ (close-output-port fport)
+ (newline)
+ (display "closures-building file ")
+ (display (string-append file '".cls"))
+ (display " is built.")))
+ ;; closurebuilding pass completed
+ ;; - - - - - - - - flattening starts - - - - - - - - -
+ (set! *passed-defs* '())
+ (for-each (lambda (def)
+ (set! *passed-defs*
+ (append (reverse (flatten-wholedef def))
+ *passed-defs*)))
+ *to-do-fun-list*)
+ (if (not (or (pair? *export-functions*) (null? *export-functions*)))
+ (set! *export-functions* *top-level-funs*)
+ (set! *export-functions*
+ (intersection *export-functions* *top-level-funs*)))
+ (if *map1-needed-flag*
+ (set! *passed-defs* (cons *map1-definition* *passed-defs*)))
+ (if *for-each1-needed-flag*
+ (set! *passed-defs* (cons *for-each1-definition* *passed-defs*)))
+ (set! *passed-defs* (reverse *passed-defs*))
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 3 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".flt"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *passed-defs*)
+ (close-output-port fport)
+ (newline)
+ (display "lambda-lifted & normalized definitions file ")
+ (display (string-append file '".flt"))
+ (display " is built.")))
+ (set! *to-do-fun-list* *passed-defs*)
+ ;; lambda-lifting & normalization finished
+ ;; - - - - - - - - - - lift statements - - - - - - - - - - -
+ (set! *passed-defs* '())
+ (do ((x 1 1))
+ ((null? *to-do-fun-list*))
+ (let ((tmp (car *to-do-fun-list*)))
+ (set! *to-do-fun-list* (cdr *to-do-fun-list*))
+ (set! *passed-defs* (append (lift-statements-wholedef tmp)
+ *passed-defs*))))
+ (set! *passed-defs* (reverse *passed-defs*))
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 4 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".stt"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *passed-defs*)
+ (close-output-port fport)
+ (newline)
+ (display "statement-lifted definitions file ")
+ (display (string-append file '".stt"))
+ (display " is built.")))
+ (set! *to-do-fun-list* *passed-defs*)
+ ;; statement-lifting pass finished
+ ;; - - - - - - - hof-dot-corrections starts - - - - - -
+ (set! *passed-ho-dot-instfuns* '())
+ (set! *passed-defs* '())
+ (do ((x 1 1))
+ ((null? *to-do-fun-list*))
+ (let ((tmp (car *to-do-fun-list*)))
+ (set! *to-do-fun-list* (cdr *to-do-fun-list*))
+ (if (not (memq (cadr tmp) *passed-ho-dot-instfuns*))
+ (set! *passed-defs* (cons (ho-dot-wholedef tmp)
+ *passed-defs*)))))
+ (set! *passed-defs*
+ (reverse (append (build-wrappers *passed-defs*)
+ *passed-defs*)))
+ (build-wrapped-interpreter-table)
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 5 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".hod"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *passed-defs*)
+ (close-output-port fport)
+ (newline)
+ (display "higher-order-&-dot-arglist corrected definitions file ")
+ (display (string-append file '".hod"))
+ (display " is built.")))
+ (set! *to-do-fun-list* *passed-defs*)
+ ;; hof-dot correction finished
+ ;; - - - - - - - typing & constant-correcting - - - - - - - - - -
+ (set! *passed-defs* '())
+ (do ((x 1 1))
+ ((null? *to-do-fun-list*))
+ (let ((tmp (car *to-do-fun-list*)))
+ (set! *to-do-fun-list* (cdr *to-do-fun-list*))
+ (set! *passed-defs* (cons (type-const-wholedef tmp)
+ *passed-defs*))))
+
+ (for-each (lambda (x)
+ (let ((tmp (assq x *extra-hobbit-primitive-defs*)))
+ (if (and tmp (not (memq x *modified-primitives*)))
+ (begin
+ (set! *passed-defs*
+ (cons (type-const-wholedef
+ (list 'define x (cadr tmp)))
+ *passed-defs*))
+ (if (memq x *extra-hobbit-dot-primitives*)
+ (set! *dot-arg-templates*
+ (cons (list x 'x) *dot-arg-templates*)))))))
+ *unknown-vars*)
+ (set! *passed-defs* (reverse *passed-defs*))
+ (init-export-funs! file)
+ (make-initialization-function! file)
+ (if *infomessages-flag*
+ (begin (newline) (display "** Pass 6 completed **")))
+ (if *build-intermediate-files*
+ (let ((fport (open-output-file (string-append file '".typ"))))
+ (for-each (lambda (x) (pretty-print x fport) (newline fport))
+ *passed-defs*)
+ (close-output-port fport)
+ (newline)
+ (display "typing & constants - corrected definitions file ")
+ (display (string-append file '".typ"))
+ (display " is built.")
+ (newline)))
+ (set! *to-do-fun-list* *passed-defs*)
+ ;; typing & constant-correcting pass finished
+ ;; - - - - - - - - building .c and .h files - - - - - - - - - -
+ (set! *passed-defs* '())
+ (let ((fport (open-output-file (string-append file '".c"))))
+ (display "#include " fport)
+ (display #\" fport)
+ (display (string-append file '".h") fport)
+ (display #\" fport)
+ (newline fport)
+ (newline fport)
+ (for-each (lambda (x) (write-c-wholefun x fport))
+ *to-do-fun-list*)
+ (close-output-port fport)
+ (if *infomessages-flag*
+ (begin (newline) (newline)
+ (display "C source file ")
+ (display (string-append file '".c"))
+ (display " is built.")
+ (newline))))
+ (let ((fport (open-output-file (string-append file '".h"))))
+ (display-header fport)
+ (newline fport)
+ (for-each (lambda (x)
+ (write-fun-declaration (cadr x) fport))
+ *to-do-fun-list*)
+ (for-each (lambda (x)
+ (if (not (memq x *fast-vars-list*))
+ (write-c-*declaration x fport)))
+ *global-vars-list*)
+ (for-each (lambda (x)
+ (write-c-*declaration (cdr x) fport))
+ *interpreter-funname-table*)
+ (for-each (lambda (x)
+ (write-c-*declaration (make-closure-scmobj-name x) fport))
+ *symbol-and-fun-list*)
+ (for-each (lambda (x)
+ (write-c-static-declaration
+ (make-closure-scmobj-name x) fport))
+ *lifted-trivial-closure-names*)
+ (for-each (lambda (x)
+ (write-c-static-declaration
+ (make-closure-scmobj-name x) fport))
+ *lifted-closure-names*)
+ (for-each (lambda (x) (write-c-static-declaration (cadr x) fport))
+ (reverse *symbol-constant-table*))
+ (for-each (lambda (x)
+ (if (not (pair? (cadr x)))
+ (write-c-static-declaration (cadr x) fport)))
+ (reverse *new-constant-list*))
+ (for-each (lambda (x)
+ (write-c-*declaration
+ (string->symbol
+ (string-append (symbol->string x) *st-vector-postfix*))
+ fport))
+ (reverse *stable-vector-names*))
+ (for-each (lambda (x) (write-c-static-declaration x fport))
+ (reverse *fast-vars-list*))
+ (newline fport)
+ (close-output-port fport)
+ (if *infomessages-flag*
+ (begin
+ (display "C header file ")
+ (display (string-append file '".h"))
+ (display " is built.")
+ (newline))))
+ ;; .c and .h files built
+ ;; - - - - - - - - - extra compilation info: - - - - - - - - -
+ (set! *via-interpreter-defined*
+ (append *via-interpreter-defined*
+ (map car *switch-args-table*)
+ *cxr-funs*
+ *non-compiled-primitives*
+ *interpreter-defined-vars*
+ (map car *floats-s->c-fun-table*)))
+ ;; - - - - - - - - - redefinability info: - - - - - - - - -
+ (if *infomessages-flag* (newline))
+ (cond
+ ((not *infomessages-flag*))
+ (*all-funs-modified-flag*
+ (newline)
+ (display "All procedure names are assumed to be redefinable (slow).")
+ (newline))
+ (*new-funs-modified-flag*
+ (newline)
+ (display
+ "All new procedure names are assumed to be redefinable (slow).")
+ (newline)
+ (if (not (null? *modified-primitives*))
+ (begin
+ (display
+ "These primitive procedure names are assumed to be redefinable (slow):")
+ (newline)
+ (display *modified-primitives*)
+ (newline))))
+ (else
+ (if (not (null? *modified-primitives*))
+ (begin
+ (display
+ "These primitive procedure names are assumed to be redefinable (slow):")
+ (newline)
+ (display *modified-primitives*)
+ (newline)))
+ (if (not (null? (set-difference *modified-top-level-names*
+ (union
+ *global-vars-list* *fast-vars-list*))))
+ (begin
+ (display
+ "These top level procedure names are assumed to be redefinable (slow):")
+ (newline)
+ (display (set-difference *modified-top-level-names*
+ (union
+ *global-vars-list* *fast-vars-list*)))
+ (newline)))))
+ ;; - - - - - - - - - hof-info: - - - - - - - - - - - - - -
+ (cond
+ ((not *infomessages-flag*))
+ ((not (null? *non-liftable-hof-names*))
+ (display
+ "These top level higher order procedures are not clonable (slow):")
+ (newline)
+ (display *non-liftable-hof-names*)
+ (newline)))
+ ;; - - - - - - - - - closures-info: - - - - - - - - - - - - -
+ (cond
+ ((not *infomessages-flag*))
+ ((not (null? *not-all-liftable-names*))
+ (display
+ "These top level procedures create non-liftable closures (slow):")
+ (newline)
+ (display *not-all-liftable-names*)
+ (newline)))
+ ;; - - - - - - - - - undefined-info: - - - - - - - - - - -
+ (if (and *infomessages-flag*
+ (not (null? (set-difference (set-difference *unknown-functions*
+ *modified-top-level-names*)
+ (union *global-vars-list*
+ (union *fast-vars-list*
+ *via-interpreter-defined*))))))
+ (begin (newline)
+ (display
+ "These nonprimitive procedures are assumed to be defined externally:")
+ (newline)
+ (display
+ (set-difference (set-difference *unknown-functions*
+ *modified-top-level-names*)
+ (union *global-vars-list*
+ (union *fast-vars-list*
+ *via-interpreter-defined*))))
+ (newline)))
+ (if (and *infomessages-flag*
+ (not (null? (set-difference (set-difference *unknown-vars*
+ *modified-top-level-names*)
+ *via-interpreter-defined*))))
+ (begin (newline)
+ (display
+ "These variables undefined (but used) in your file were defined:")
+ (newline)
+ (display (set-difference (set-difference *unknown-vars*
+ *modified-top-level-names*)
+ *via-interpreter-defined*))
+ (newline)))
+ (if *infomessages-flag* (newline))))
+
+(define (sort-out-toplevel! lst file)
+ (set! *to-do-fun-list* '())
+ (set! *inline-funs* '())
+ (set! *inline-vars* '())
+ (set! *global-vars-list* '())
+ (set! *fast-vars-list* '())
+ (set! *var-make-list* '())
+ (set! *non-directcomp-list* '())
+ (set! *top-actions-list* '())
+ (do ((part lst (cdr part)))
+ ((null? part))
+ (let ((el (car part))
+ (tmp '()))
+ (cond
+ ((and (list? el)
+ (eq? 'begin (car el)))
+ (set! part (append el (cdr part))))
+ ((and (pair? el)
+ (or (eq? 'load (car el))
+ (eq? 'require (car el))))
+ (report-warning "ignoring a load on top level: " el))
+ ((or (not (pair? el))
+ (not (eq? 'define (car el)))
+ (null? (cdr el))
+ (not (list? el)))
+ ;; (report-error "the compiled file contains a non-definition: "
+ ;; el)
+ ;; (if (pair? el)
+ ;; (set! *non-directcomp-list* (cons el *non-directcomp-list*)))
+
+ (set! *top-actions-list* (cons el *top-actions-list*)))
+
+ ;; from here everything starts with 'define'.
+
+ ((or (pair? (cadr el)) ; the standard direct function def
+ (and (not (null? (cddr el)))
+ (pair? (caddr el))
+ (eq? 'lambda (car (caddr el)))))
+ ;;(and (pair? (cddr el))
+ ;; (pair? (caddr el))
+ ;; (memq (car (caddr el)) '(let let* letrec))
+ ;; (pair? (cddr (caddr el)))
+ ;; (pair? (caddr (caddr el)))
+ ;; (eq? 'lambda (car (caddr (caddr el)))))
+ ;; ;(not (find-if (lambda (x) (not (eq? (car x) (cadr x))))
+ ;; ; (cadr (caddr el))))
+ (let* ((def (normalize-top-define el))
+ (funname (cadr def))
+ (tmp '()))
+ (if (modified-fun? funname)
+ (set! *top-actions-list*
+ (cons (cons 'set! (cdr def)) *top-actions-list*))
+ (begin
+ (set! tmp (list *special-pseudoquote* funname))
+ (set! *top-actions-list* (cons tmp *top-actions-list*))
+ (set! *to-do-fun-list* (cons def *to-do-fun-list*))))))
+ ;; the following filters out macro defs:
+ ((and (pair? el)
+ (pair? (cdr el))
+ (eq? 'define (car el))
+ (not (pair? (cadr el)))
+ (pair? (cddr el))
+ (pair? (caddr el))
+ (eq? 'let (caaddr el))
+ (pair? (car (my-last-pair (caddr el))))
+ (eq? 'defmacro:transformer (caar (my-last-pair (caddr el))))))
+
+ ;; - - - from here everything will be a define-expression - - - -
+
+ ;;((and (pair? (caddr el))
+ ;; (not (eq? 'quote (car (caddr el))))
+ ;; (not (eq? 'quasiquote (car (caddr el)))))
+
+ ;; (set! *top-actions-list*
+ ;; (cons (cons 'set! (cdr el)) *top-actions-list*)))
+
+ ;;(set! tmp (make-pair-constant (caddr el)))
+ ;;(set! *top-actions-list*
+ ;; (cons (list 'set! (cadr el) (list *actual-c-eval* tmp))
+ ;; *top-actions-list*))
+ ;; (set! *via-interpreter-defined*
+ ;; (cons (cadr el) *via-interpreter-defined*))
+
+ ;; - - - - - - - - - declarations-part starts - - - - - - - - -
+ ((eq? (cadr el) *inline-declare*)
+ (set! *inline-funs* (append (cadr (caddr el)) *inline-funs*)))
+ ((eq? (cadr el) *inline-vars-declare*)
+ (set! *inline-vars* (append (cadr (caddr el)) *inline-vars*)))
+ ((eq? (cadr el) *allnumbers-declare*)
+ (set! *floats-flag* el))
+ ((eq? (cadr el) *all-funs-modified-declare*)
+ (set! *all-funs-modified-flag* #t))
+ ((eq? (cadr el) *new-funs-modified-declare*)
+ (set! *new-funs-modified-flag* #t))
+ ((eq? (cadr el) *stable-vectors-declare*)
+ (set! *stable-vector-names*
+ (append (cadr (caddr el))
+ *stable-vector-names*)))
+ ((eq? (cadr el) *fast-vars-declare*)
+ (set! *fast-vars-list*
+ (append (cadr (caddr el)) *fast-vars-list*)))
+ ((eq? (cadr el) *export-declare*)
+ (set! *export-functions*
+ (append (cadr (caddr el))
+ (if (pair? *export-functions*)
+ *export-functions*
+ '()))))
+ ;; - - - - - - - - -declarations-part ends - - - - - - - - - -
+ ((null? (cddr el)) ; form: (define foo)
+ (set! *global-vars-list* (cons (cadr el) *global-vars-list*))
+ (set! *top-actions-list*
+ (cons (list 'set! (cadr el) *unspecified*)
+ *top-actions-list*))
+ (if (not (memq (cadr el) *fast-vars-list*))
+ (set! *var-make-list*
+ (cons `(set!
+ ,(cadr el)
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string (cadr el)))
+ ,(string-length
+ (symbol->string (cadr el)))))))
+ *var-make-list*))))
+
+ (else ; form: (define foo <term>)
+ (set! *global-vars-list* (cons (cadr el) *global-vars-list*))
+ (set! *top-actions-list*
+ (cons (cons 'set! (cdr el)) *top-actions-list*))
+
+ ;;(if (symbol? (caddr el))
+ ;; ; the last el of define is a symbol; call intern:
+ ;; (set! *top-actions-list*
+ ;; (cons `(set!
+ ;; ,(cadr el)
+ ;; ,(list *actual-c-eval*
+ ;; (make-pair-constant-aux (caddr el))))
+ ;;(,*c-adr* (cdr (,*intern-function*
+ ;; (,*actual-c-string*
+ ;; ,(symbol->string (caddr el)))
+ ;; (,*actual-c-int*
+ ;; ,(string-length
+ ;; (symbol->string
+ ;; (caddr el)))))))
+ ;; *top-actions-list*))
+ ;; ; the last el of define is a non-list non-symbol:
+ ;; (set! *top-actions-list*
+ ;; (cons (cons 'set! (cdr el))
+ ;; *top-actions-list*)))
+ ;;(set! *via-interpreter-defined*
+ ;; (cons (cadr el) *via-interpreter-defined*))
+ (if (not (memq (cadr el) *fast-vars-list*))
+ (set! *var-make-list*
+ (cons `(set!
+ ,(cadr el)
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string (cadr el)))
+ ,(string-length
+ (symbol->string (cadr el)))))))
+ *var-make-list*)))))))
+ ;;(if (not (null? *top-actions-list*))
+ ;; (set! *to-do-fun-list*
+ ;; (cons (list 'define
+ ;; (make-globals-name file)
+ ;; (list* 'lambda
+ ;; '()
+ ;; (reverse (cons '() *top-actions-list*))))
+ ;; *to-do-fun-list*)))
+
+ ;; - - - - - - - - making the top-actions-fun - - - - - - -- - -
+
+ (let* ((init-all-list (reverse *top-actions-list*))
+ (init-all-splitted-lists (list '()))
+ (fname '())
+ (init-all-splitted-processed '())
+ (top-actions-fun '())
+ (split-nr 0))
+
+ ;; split up the big list
+ (do ((n 1 (+ n 1)))
+ ((null? init-all-list))
+ (if (> n *max-auxfun-size*)
+ (begin
+ (set! n 1)
+ (set! init-all-splitted-lists
+ (cons '() init-all-splitted-lists))))
+ (set! init-all-splitted-lists
+ (cons (cons (car init-all-list) (car init-all-splitted-lists))
+ (cdr init-all-splitted-lists)))
+ (set! init-all-list (cdr init-all-list)))
+
+ ;;(display "init-all-splitted-lists: ")
+ ;;(newline)
+ ;;(pretty-print init-all-splitted-lists)
+ ;;(newline)
+ (set! init-all-splitted-lists (reverse init-all-splitted-lists))
+ ;; process each sublist
+ (do ((lst init-all-splitted-lists (cdr lst)))
+ ((null? lst))
+ (set! split-nr (+ 1 split-nr))
+ (set! fname
+ (string->symbol
+ (string-append *top-actions-prefix*
+ (string-append
+ (number->string split-nr)
+ "_"
+ file))))
+ (set! *splitted-topaction-function-names*
+ (cons fname *splitted-topaction-function-names*))
+ (set! init-all-splitted-processed
+ (cons
+ (list 'define
+ fname
+ (list 'lambda
+ '()
+ (list* 'let* '() (reverse (car lst)))))
+ init-all-splitted-processed)))
+
+ ;;(display "init-all-splitted-processed: ")
+ ;;(newline)
+ ;;(pretty-print init-all-splitted-processed)
+ ;;(newline)
+
+ (set! top-actions-fun
+ (list
+ 'define (make-top-actions-funname file)
+ (list* 'lambda '()
+ (map list
+ (reverse *splitted-topaction-function-names*)))))
+
+ (set! *to-do-fun-list*
+ (cons top-actions-fun
+ (append init-all-splitted-processed
+ *to-do-fun-list*))))
+
+ ;; - - - - - - - - top-actions-fun is made and kept - - - - - - -
+ (set! *to-do-fun-list* (reverse *to-do-fun-list*))
+ (set! *non-directcomp-list* (reverse *non-directcomp-list*))
+ (set! *inline-funs-data* '())
+ (set! *inline-vars-data* '())
+ (do ((part *inline-vars* (cdr part)))
+ ((null? part))
+ (let ((tmp (member-if (lambda (x)
+ (and (pair? x)
+ (eq? 'set! (car x))
+ (eq? (cadr x) (car part))))
+ *top-actions-list*)))
+ (if tmp
+ (set! *inline-vars-data*
+ (cons (cdar tmp) *inline-vars-data*))
+ (set! *inline-vars* (remove (car part) *inline-vars*)))))
+ (do ((part *inline-funs* (cdr part)))
+ ((null? part))
+ (let ((tmp (member-if (lambda (x)
+ (or (eq? (cadr x) (car part))
+ (and (pair? (cadr x))
+ (eq? (caadr x) (car part)))))
+ *to-do-fun-list*)))
+ (if tmp
+ (set! *inline-funs-data*
+ (cons (list (car part)
+ (make-inline-body (car tmp)))
+ *inline-funs-data*))
+ (set! *inline-funs* (remove (car part) *inline-funs*))))))
+
+
+
+(define (normalize-top-define term)
+ (if (or (not (pair? (cdr term)))
+ (not (pair? (cddr term))))
+ (report-error "incorrect define: " term))
+ (if (pair? (cadr term))
+ `(define ,(caadr term) (lambda ,(cdadr term) ,@(cddr term)))
+ term))
+
+(define (make-inline-body def)
+ (let* ((tmp (rename-vars
+ (lettify-lambdas
+ (normalize-defines
+ (compile-quasiquote def))
+ 200
+ #t)))
+ (term (caddr tmp))
+ (body (cddr term)))
+ (cond ((not (list? (cadr term)))
+ (report-error "inline-function has a non-list arglist: "
+ def))
+ ((null? body)
+ (report-error "inline-function has no body: " def))
+ ((null? (cdr body))
+ term)
+ (else
+ (list (car term)
+ (cadr term)
+ (cons 'begin body))))))
+
+
+(define (make-initialization-function! file)
+ (let* ((nondefines
+ (map make-pair-constant *non-directcomp-list*))
+ (vector-elts
+ (map (lambda (x)
+ `(set! ,(string->symbol
+ (string-append
+ (symbol->string x)
+ *st-vector-postfix*))
+ (,*velts-function*
+ (,*global-access* ,x))))
+ *stable-vector-names*))
+ (init-all-list
+ (append
+ (init-closure-funs file *passed-defs*)
+ (init-interpretable-funs)
+ *var-make-list*
+ (reverse *symbol-list*)
+ (reverse *new-constant-list*)
+ (if (null? *top-actions-list*)
+ '()
+ (list
+ (list (make-top-actions-funname file))))
+ vector-elts
+ (map (lambda (x)
+ (list *c-eval-fun* x))
+ nondefines)))
+ (init-all-splitted-lists (list '()))
+ (init-all-splitted-processed '())
+ (split-nr 0)
+ (main-fun '())
+ (fname '()))
+
+
+ ;;(display "init-all-list: ")
+ ;;(newline)
+ ;;(pretty-print init-all-list)
+ ;;(newline)
+
+ ;; split up the big list
+ (do ((n 1 (+ n 1)))
+ ((null? init-all-list))
+ (if (> n *max-auxfun-size*)
+ (begin
+ (set! n 1)
+ (set! init-all-splitted-lists
+ (cons '() init-all-splitted-lists))))
+ (set! init-all-splitted-lists
+ (cons (cons (car init-all-list) (car init-all-splitted-lists))
+ (cdr init-all-splitted-lists)))
+ (set! init-all-list (cdr init-all-list)))
+
+ ;;(display "init-all-splitted-lists: ")
+ ;;(newline)
+ ;;(pretty-print init-all-splitted-lists)
+ ;;(newline)
+ (set! init-all-splitted-lists (reverse init-all-splitted-lists))
+ ;; process each sublist
+ (do ((lst init-all-splitted-lists (cdr lst)))
+ ((null? lst))
+ (set! split-nr (+ 1 split-nr))
+ (set! fname
+ (string->symbol
+ (string-append *init-fun-prefix*
+ (string-append
+ (number->string split-nr)
+ "_"
+ file))))
+ (set! *splitted-init-function-names*
+ (cons fname *splitted-init-function-names*))
+ (set! init-all-splitted-processed
+ (cons
+ (list 'define
+ fname
+ (list 'lambda
+ '()
+ (list* 'let* '() (reverse (car lst)))))
+ init-all-splitted-processed)))
+
+ ;;(display "init-all-splitted-processed: ")
+ ;;(newline)
+ ;;(pretty-print init-all-splitted-processed)
+ ;;(newline)
+
+ (set! main-fun
+ (list 'define
+ (string->symbol (string-append *init-fun-prefix* file))
+ (list 'lambda
+ '()
+ (list* 'let* '()
+ (map list
+ (reverse *splitted-init-function-names*))))))
+
+ (set! *passed-defs*
+ (append *passed-defs*
+ (append (reverse init-all-splitted-processed)
+ (list main-fun))))))
+
+
+(define (init-export-funs! file)
+ (let* ((res '())
+ (topactions-funname (make-top-actions-funname file)))
+ (set! *export-functions*
+ (remove (make-globals-name file) *export-functions*))
+ (for-each
+ (lambda (x)
+ (set! res (init-export-fun-aux x))
+ (if res
+ (for-each
+ (lambda (name)
+ (let ((fun (car (member-if
+ (lambda (x) (eq? (cadr x) name))
+ *passed-defs*))))
+ (subst-term-equal!
+ res (list *special-pseudoquote* (cadr x)) fun)))
+ (cons topactions-funname
+ *splitted-topaction-function-names*))))
+ *passed-defs*)))
+
+
+(define (init-export-fun-aux def)
+ (if (not (memq (cadr def) *export-functions*))
+ #f
+ (let* ((tmp1 (assq (cadr def) *export-table*))
+ (tmp (assq (cadr def) *wrapper-table*))
+ (arity '())
+ (flag '())
+ (res '()))
+ (cond (tmp (set! arity 'x))
+ ((begin
+ (set! arity (assq (cadr def) *dot-arg-templates*))
+ (and arity
+ (symbol? (cadr arity))))
+ (set! arity 'x))
+ (else (set! arity (cadr (caddr def)))))
+ (cond ((symbol? arity)
+ (set! flag 'tc7_lsubr))
+ (else
+ (set! flag
+ (cadr (assq (length arity)
+ '((0 tc7_subr_0)
+ (1 tc7_subr_1)
+ (2 tc7_subr_2)
+ (3 tc7_subr_3)))))))
+ (set! res
+ (list 'make_subr
+ (list *actual-c-string*
+ (if (memq (cadr def) *symbol-and-fun-list*)
+ (symbol->string
+ (make-closure-scmobj-name (cadr def)))
+ (symbol->string (cadr def))))
+ flag
+ (if tmp
+ (cadr tmp)
+ (if tmp1
+ (cadr tmp1)
+ (cadr def)))))
+ (if (memq (cadr def) *symbol-and-fun-list*)
+ (set! res `(set! (,*global-access*
+ ,(make-closure-scmobj-name (cadr def)))
+ ,res)))
+ res)))
+
+
+(define (init-closure-funs file defs)
+ (append
+ (map
+ (lambda (funname)
+ (let* ((procname (make-closure-scmobj-name funname))
+ (def-part '()))
+ (set! def-part (member-if (lambda (x) (eq? funname (cadr x))) defs))
+ `(set! ,procname ,(init-export-fun-aux (car def-part)))))
+ *lifted-trivial-closure-names*)
+ (map
+ (lambda (funname)
+ (let* ((procname (make-closure-scmobj-name funname)))
+ `(set! ,procname (make_subr (,*actual-c-string*
+ ,(symbol->string procname))
+ tc7_lsubr
+ ,funname))))
+ *lifted-closure-names*)))
+
+
+(define (init-interpretable-funs)
+ (map
+ (lambda (x)
+ (list 'set! (cdr x)
+ `(,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string (car x)))
+ ,(string-length
+ (symbol->string (car x))))))))
+ *interpreter-funname-table*))
+
+
+(define (make-globals-name file)
+ (string->symbol (string-append *init-globals-prefix* file)))
+
+(define (make-top-actions-funname file)
+ (string->symbol (string-append *top-actions-prefix* file)))
+
+(define (descmify str)
+ (let ((len (string-length str)))
+ (if (and (> len 4)
+ (string-ci=? ".scm" (substring str (- len 4) len)))
+ (substring str 0 (- len 4))
+ str)))
+
+
+
+
+(define (display-header fport)
+ (define *h-port* fport)
+ (define (headerline s)
+ (display s *h-port*)
+ (newline *h-port*))
+ (if *floats-flag* (headerline "#define FLOATS"))
+ (headerline "#include \"scmhob.h\"")
+ (headerline ""))
+
+(define (init-global)
+ (set! *floats-flag* #f)
+ (set! *tmp-vars* '())
+ (set! *new-fun-names* '())
+ (set! *new-fun-nr* 0)
+ (set! *higher-order-funs* '())
+ (set! *higher-order-templates* '())
+ (set! *new-parameter-nr* '0)
+ (set! *dot-arg-funs* '())
+ (set! *dot-arg-templates* '())
+ (set! *new-instnr* '0)
+ (set! *new-primitive-instnr* '0)
+ (set! *new-constant-list* '())
+ (set! *symbol-constant-table* '())
+ (set! *interpreter-funname-table* '())
+ (set! *new-constant-num* 0)
+ (set! *char-replacements-lists* '())
+ (set! *splitted-init-function-names* '())
+ (set! *splitted-topaction-function-names* '())
+ (set! *map1-needed-flag* #f)
+ (set! *for-each1-needed-flag* #f)
+ (set! *symbol-list* '())
+ (set! *unknown-functions* '())
+ (set! *unknown-vars* '())
+ (set! *top-level-funs* '())
+ (set! *inline-funs* '())
+ (set! *inline-vars* '())
+ (set! *export-functions* #f)
+ (set! *export-table* '())
+ (set! *wrapper-table* '())
+ (set! *stable-vector-names* '())
+ (set! *fast-vars-list* '())
+ (set! *closure-var-vectornames* '())
+ (set! *lifted-closures-to-do* '())
+ (set! *lifted-trivial-closure-names* '())
+ (set! *lifted-closure-names* '())
+ (set! *via-interpreter-defined* '())
+ (set! *special-c-vars* '())
+ (set! *closure-name-nr* 0)
+ (set! *closure-vector-name-nr* 0)
+ (set! *liftable-hof-database* '())
+ (set! *letrec-closure-nr* 0)
+ (set! *not-all-liftable-names* '())
+ (set! *all-funs-modified-flag* #f)
+ (set! *new-funs-modified-flag* #f)
+ (set! *symbol-and-fun-list* '())
+ (set! *hobbit-declaration-vars*
+ (list *inline-declare* *inline-vars-declare* *allnumbers-declare*
+ *all-funs-modified-declare* *new-funs-modified-declare*
+ *export-declare* *stable-vectors-declare* *fast-vars-declare*))
+ (set! *primitives*
+ (append (map car *switch-args-table*)
+ *cxr-funs*
+ *non-compiled-primitives*
+ (map car *floats-s->c-fun-table*)))
+ (do ((nr 1 (+ 1 nr)))
+ ((= nr *tmp-var-max*))
+ (set! *tmp-vars*
+ (cons (string->symbol (string-append *tmp-var-name*
+ (number->string nr)))
+ *tmp-vars*)))
+ (set! *tmp-vars* (reverse *tmp-vars*)))
+
+
+;; set-primitive-tables sets tables differently for the float and non-float case
+
+(define (set-primitive-tables)
+ (set! *num-arg-c-funs*
+ (append
+ (if *badivsgns-flag*
+ '()
+ '(quotient remainder))
+ (if *floats-flag*
+ '()
+ '(/))
+ '(logxor lognot logsleft logsright
+ = < > <= >= + - *
+ %= %< %> %<= %>= %+ %- %* %/)))
+ (set! *always-num-arg-c-funs*
+ ;;if *badivsgns-flag*
+ ;; '()
+ ;; '(quotient remainder))
+ '(logxor lognot logsleft logsright
+ %= %< %> %<= %>= %+ %- %* %/))
+ (set! *num-res-c-funs*
+ (append
+ (if *badivsgns-flag*
+ '()
+ '(quotient remainder))
+ (if *floats-flag*
+ '()
+ '(/))
+ '(logxor lognot logsleft logsright
+ + - *
+ %+ %- %* %/)))
+ (set! *bool-arg-c-funs*
+ (cons *and?* (cons *or?* (list *not?*))))
+ (set! *always-bool-res-c-funs*
+ (cons *and?*
+ (cons *or?*
+ (cons *not?*
+ '(boolean? symbol? char? vector? pair?
+ string? number? complex?
+ eq? char=? null?
+ %eqv? %zero? %negative? %positive? %number?
+ %= %< %> %<= %>= )))))
+ (set! *bool-res-c-funs*
+ (cons *and?*
+ (cons *or?*
+ (cons *not?*
+ '(boolean? symbol? char? vector? pair?
+ string? number? real? rational? complex?
+ integer?
+ eq? eqv? char=? null? zero? negative? positive?
+ = < > <= >=
+ %eqv? %zero? %negative? %positive? %number?
+ %= %< %> %<= %>= ))))))
+
+
+(define (report-warning . lst)
+ (display #\newline)
+ (display "COMPILER WARNING: ")
+ (display #\newline)
+ (for-each display lst)
+ (display #\newline))
+
+;;=================================================================
+;;
+;; final conversion to C
+;;
+;;=================================================================
+
+(define (write-c-*declaration var port)
+ (set! *c-port* port)
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c #\*)
+ (display-c-var var)
+ (display-c #\;)
+ (display-c-newline))
+
+(define (write-fun-declaration var port)
+ (set! *c-port* port)
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-var var)
+ (display-c "()")
+ (display-c #\;)
+ (display-c-newline))
+
+(define (write-c-static-declaration var port)
+ (set! *c-port* port)
+ (display-c "static ")
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-var var)
+ (display-c #\;)
+ (display-c-newline))
+
+
+(define (write-c-wholefun def port)
+ (let* ((fun (caddr def))
+ (top-let (caddr fun)))
+ (set! *c-port* port)
+ (set! *current-fun-name* (cadr def))
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-var (cadr def))
+ (display-c-lst (args->list (cadr fun)) #\( #f)
+ (display-c-newline)
+ (if (not (null? (cadr fun)))
+ (begin
+ (let ((scm-args (filter (lambda (x) (symbol? x)) (cadr fun)))
+ (fun-args (filter (lambda (x)
+ (and (pair? x) (eq? *function* (car x))))
+ (cadr fun)))
+ (ptr-args (filter (lambda (x)
+ (and (pair? x) (eq? *c-adr* (car x))))
+ (cadr fun))))
+ (if (not (null? ptr-args))
+ (begin
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-lst (map cadr ptr-args) #f #\*)
+ (display-c #\;)
+ (display-c-newline)))
+ (if (not (null? fun-args))
+ (begin
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-lst (map cadr fun-args) #f 'function)
+ (display-c #\;)
+ (display-c-newline)))
+ (if (not (null? scm-args))
+ (begin
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-lst scm-args #f #f)
+ (display-c #\;)
+ (display-c-newline))))))
+ (display-c #\{)
+ (display-c-newline)
+ (if (and (not (null? (cadr top-let)))
+ (find-if (lambda (x) (symbol? (car x))) (cadr top-let)))
+ (begin
+ (display-c-indent 1)
+ (display-c *scm-type*)
+ (display-c #\space)
+ (display-c-lst (filter (lambda (x) (symbol? x))
+ (map car (cadr top-let)))
+ #f #f)
+ (display-c #\;)
+ (display-c-newline)
+ (display-c-newline)))
+ (for-each (lambda (x)
+ (display-c-statement x 1))
+ (cddr top-let))
+ (display-c #\})
+ (display-c-newline)
+ (display-c-newline)))
+
+(define (display-c x)
+ (display x *c-port*))
+
+
+;;(define (write-c-string x)
+;; (write x *c-port*))
+
+(define (write-c-string x)
+ (display "\"" *c-port*)
+ (for-each
+ (lambda (c)
+ (cond
+ ((eq? c #\nl) (display "\\n" *c-port*))
+ ((eq? c #\") (display "\\\"" *c-port*))
+ ((eq? c #\ht) (display "\\t" *c-port*))
+ ((eq? c #\\) (display "\\\\" *c-port*))
+ (else (display c *c-port*))))
+ (string->list x))
+ (display "\"" *c-port*))
+
+
+(define (display-c-newline)
+ (newline *c-port*))
+
+(define (display-c-indent n)
+ (do ((m 0 (+ 1 m)))
+ ((= n m))
+ (display-c *c-indent*)))
+
+(define (display-c-lst lst par prefix)
+ (let ((separator #\,))
+ (cond ((char=? par #\()
+ (set! separator #\,)
+ (display-c #\())
+ ((char=? par #\{)
+ (set! separator #\;)
+ (display-c #\{))
+ (else
+ (set! separator #\,)))
+ (if (not (null? lst))
+ (begin
+ (for-each (lambda (x)
+ (cond ((and (pair? x)
+ (eq? 'set! (car x))
+ (eq? 3 (length x))
+ (eq? *dummy* (caddr x))))
+ ((or (char? prefix) (string? prefix))
+ (display-c prefix)
+ (display-c-expression x #t)
+ (display-c separator))
+ ((eq? 'function prefix)
+ (display-c "(*")
+ (display-c-expression x #t)
+ (display-c ") ()")
+ (display-c separator))
+ (else
+ (display-c-expression x #t)
+ (display-c separator))))
+ (butlast lst 1))
+ (cond ((or (char? prefix) (string? prefix))
+ (display-c prefix)
+ (display-c-expression (car (my-last-pair lst)) #t))
+ ((eq? 'function prefix)
+ (display-c "(*")
+ (display-c-expression (car (my-last-pair lst)) #t)
+ (display-c ") ()"))
+ (else
+ (display-c-expression (car (my-last-pair lst)) #t)))))
+ (cond ((char=? par #\()
+ (display-c #\)))
+ ((char=? par #\{)
+ (display-c #\;)
+ (display-c #\})))))
+
+
+
+
+(define (display-var var port)
+ (cond
+ ((eq? *listofnull* var)
+ (display "listofnull" port))
+ ((eq? *unspecified* var)
+ (display "UNSPECIFIED" port))
+ (else
+ (let* ((str (symbol->string var))
+ (char '())
+ (replacement '())
+ (len (string-length str))
+ (global-flag #f))
+ (if (and (symbol? var)
+ (char-numeric? (string-ref str 0)))
+ (display *c-num-symb-prefix* port))
+ (if (and (char=? #\* (string-ref str 0))
+ (char=? #\* (string-ref str (- len 1))))
+ (set! global-flag #t))
+ (do ((n 0 (+ 1 n)))
+ ((= n len))
+ (set! char (string-ref str n))
+ (cond ((and global-flag
+ (or (= 0 n) (= n (- len 1))))
+ char) ; do nothing
+ ((char-alphabetic? char)
+ (display (char-downcase char) port))
+ ((char-numeric? char)
+ (display char port))
+ ((begin
+ (set! replacement (assoc char *char-replacements*))
+ replacement)
+ (display (cadr replacement) port))
+ (else
+ (display char port))))
+ (cond ((memq var *c-keywords*)
+ (display *c-keyword-postfix* port))
+ (global-flag
+ (display *global-postfix* port)))))))
+
+
+(define (display-c-var var)
+ (display-var var *c-port*))
+
+
+(define (display-c-statement term n)
+ (let ()
+ (cond ((not (pair? term)))
+ ;; (display-c-indent n)
+ ;; (display-c #\;) ; empty operator
+ ;; (display-c-newline))
+ ((eq? 'if (car term))
+ (display-c-indent n)
+ (display-c "if(")
+ (display-c-expression (cadr term) #t)
+ (display-c #\))
+ (cond ((not (pair? (caddr term)))
+ (display-c #\space)
+ (display-c #\;) ; empty operator
+ (display-c-newline))
+ ((and (not (eq? 'begin (car (caddr term))))
+ (not (eq? 'if (car (caddr term)))))
+ (display-c-newline)
+ (display-c-statement (caddr term) (+ 1 n)))
+ ((eq? 'begin (car (caddr term)))
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x) (display-c-statement x (+ 1 n)))
+ (cdar (cddr term)))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ ((eq? 'if (car (caddr term)))
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (display-c-statement (car (cddr term)) (+ 1 n))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ (else (report-error "wrong syntax: " term)))
+ (cond ((null? (cdddr term))) ; do nothing
+ ((not (pair? (car (cdddr term))))) ; do nothing
+ ((and (not (eq? 'begin (caar (cdddr term))))
+ (not (eq? 'if (caar (cdddr term)))))
+ (display-c-indent n)
+ (display-c "else")
+ (display-c-newline)
+ (display-c-statement (car (cdddr term)) (+ 1 n)))
+ ((eq? 'begin (caar (cdddr term)))
+ (display-c-indent n)
+ (display-c "else")
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x) (display-c-statement x (+ 1 n)))
+ (cdar (cdddr term)))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ ((eq? 'if (caar (cdddr term)))
+ (display-c-indent n)
+ (display-c "else")
+ (display-c-newline)
+ (display-c-statement (car (cdddr term)) n))))
+ ((eq? (car term) *do-not*)
+ (display-c-indent n)
+ (display-c "for(")
+ (let ((lst1 (map (lambda (x) (list 'set! (car x) (cadr x)))
+ (cadr term)))
+ (lst2 (map (lambda (x) (list 'set! (car x) (caddr x)))
+ (filter (lambda (y) (not (null? (cddr y))))
+ (cadr term)))))
+ (if (not (null? lst1))
+ (display-c-lst lst1 #f #f))
+ (display-c #\;)
+ (if (> (length lst1) 1)
+ (begin
+ (display-c-newline) (display-c-indent n) (display-c " ")))
+ (display-c-expression (caar (cddr term)) #t)
+ (display-c #\;)
+ (if (and (> (length lst1) 1) (not (null? lst2)))
+ (begin
+ (display-c-newline) (display-c-indent n) (display-c " ")))
+ (if (not (null? lst2))
+ (display-c-lst lst2 #f #f))
+ (display-c #\))
+ (cond ((or (null? (cdddr term))
+ (not (find-if (lambda (x) (pair? x)) (cdddr term))))
+ (display-c #\space)
+ (display-c #\;) ; empty operator
+ (display-c-newline))
+ ((null? (cdr (cdddr term)))
+ (if (or (eq? 'begin (caar (cdddr term)))
+ (eq? *op-begin* (caar (cdddr term))))
+ (begin
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x)
+ (display-c-statement x (+ 1 n)))
+ (cdar (cdddr term)))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ (begin
+ (display-c-newline)
+ (display-c-statement (car (cdddr term))
+ (+ 1 n)))))
+ (else
+ (display-c #\space)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x)
+ (display-c-statement x (+ 1 n)))
+ (cdddr term))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline)))))
+ ((or (eq? (car term) 'begin) (eq? (car term) *op-begin*))
+ (display-c-indent n)
+ (display-c #\{)
+ (display-c-newline)
+ (for-each (lambda (x) (display-c-statement x (+ 1 n)))
+ (cdr term))
+ (display-c-indent n)
+ (display-c #\})
+ (display-c-newline))
+ ((eq? (car term) *return*)
+ (display-c-indent n)
+ (display-c "return ")
+ (display-c-expression (cadr term) #t)
+ (display-c #\;)
+ (display-c-newline))
+ ((or (eq? *tailrec* (car term)) (eq? *mark-tailrec* (car term)))
+ (display-c "tailrecursion:")
+ (display-c-newline))
+ ((eq? *goto-tailrec* (car term))
+ (display-c-indent n)
+ (display-c "goto tailrecursion;")
+ (display-c-newline))
+ ((and (eq? 'set! (car term))
+ (eq? *dummy* (caddr term)))) ; do nothing
+ (else
+ (display-c-indent n)
+ (display-c-expression term)
+ (display-c #\;)
+ (display-c-newline)))))
+
+(define (display-c-expression term . no-par-flag)
+ (let ((fn (if (pair? term) (car term) '()))
+ (args (if (pair? term) (cdr term) '()))
+ (tmp #f))
+ (cond
+ ((symbol? term)
+ (display-c-var term))
+ ((number? term)
+ (display-c term)
+ (if *long-cast-flag* (display-c "L")))
+ ((boolean? term)
+ (if term (display-c *c-true*) (display-c *c-false*)))
+ ((char? term)
+ (if (printable-char? term)
+ (begin
+ (display-c #\')
+ (display-c term)
+ (display-c #\'))
+ (display-c (char->integer term))))
+ ((null? term)
+ (display-c *c-null*))
+ ((not (pair? term))
+ (report-error "wrong type of object for C: " term))
+ ((and (eq? *bool-c->s* fn)
+ (boolean? (car args)))
+ (if (car args)
+ (display-c "BOOL_T")
+ (display-c "BOOL_F")))
+ ((eq? *c-adr* fn)
+ (display-c #\&)
+ (display-c-expression (car args)))
+ ((eq? *c-fetch* fn)
+ (display-c #\*)
+ (display-c-expression (car args)))
+ ((eq? fn *higher-order-call*)
+ (display-c "(*")
+ (display-c-var (car args))
+ (display-c ")")
+ (display-c-lst (cdr args) #\( #f))
+ ((eq? *function* fn)
+ (display-c-expression (car args)))
+ ((or (eq? fn 'begin) (eq? fn *op-begin*))
+ (display-c-lst args #\( #f))
+ ((eq? fn *op-if*)
+ (display-c #\()
+ (display-c-expression (car args))
+ (display-c " ? ")
+ (display-c-expression (cadr args))
+ (display-c " : ")
+ (display-c-expression
+ (if (null? (cddr args))
+ *unspecified*
+ (caddr args)))
+ (display-c #\)))
+ ((eq? fn *actual-c-string*)
+ (display-c "(char *)")
+ (write-c-string (car args)))
+ ((eq? fn *actual-c-expr*)
+ (display-c (car args)))
+ ((eq? fn *actual-c-int*)
+ (display-c (car args)))
+ ((eq? fn *actual-c-eval*)
+ (display-c "eval(")
+ (display-c-var (car args))
+ (display-c ")"))
+ ((eq? 'set! fn)
+ (or (eq? *dummy* (cadr args))
+ (begin (display-c-expression (car args))
+ (display-c *c-infix-surround*)
+ (display-c "=")
+ (display-c *c-infix-surround*)
+ (display-c-expression (cadr args)))))
+ ((begin (set! tmp (assq fn *switch-args-table*))
+ tmp)
+ (display-c-expression (cons (cadr tmp) (reverse args))))
+ ((and (begin (set! tmp (assq fn *add-args-table*))
+ tmp)
+ (not (= (length args) (caddr tmp))))
+ (display-c-expression
+ (cons fn (append args (list (cadr tmp))))))
+
+ ((begin (if (memq fn '(vector string))
+ (set! args (list (normalize-list-for-c args))))
+ #f)) ; never succeeds
+ ((begin (set! tmp (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*)))
+ tmp)
+ (cond ((and (not (null? (cdddr tmp)))
+ (car (cdddr tmp)))
+ (if (or (null? no-par-flag)
+ (not (car no-par-flag)))
+ (display-c #\())
+ (display-c-expression (car args))
+ (display-c *c-infix-surround*)
+ (display-c (cadr tmp))
+ (display-c *c-infix-surround*)
+ (display-c-expression (cadr args))
+ (if (or (null? no-par-flag)
+ (not (car no-par-flag)))
+ (display-c #\))))
+ (else
+ (display-c (cadr tmp))
+ (display-c-lst args #\( #f))))
+ (else
+ (display-c-expression fn)
+ (display-c-lst args #\( #f)))))
+
+
+
+(define (printable-char? chr)
+ (or (char-alphabetic? chr)
+ (char-numeric? chr)
+ (memq chr '(#\! #\@ #\$ #\% #\^ #\& #\* #\( #\)
+ #\_ #\+ #\| #\- #\=
+ #\{ #\} #\[ #\]
+ #\; #\, #\. #\/
+ #\: #\" #\~ #\< #\> #\?
+ #\space))))
+
+
+(define *non-compiled-primitives*
+ '(apply call-with-current-continuation apply force delay load
+ map for-each list call-with-input-file call-with-output-file
+ open-input-file open-output-file with-input-from-file
+ with-output-to-file string-append
+ logical:logxor logical:lognot logical:logior logical:logand
+ logical:ash logical:logcount logical:integer-length
+ logical:bit-extract logical:integer-expt
+ defmacro:expand*
+ sin cos tan asin acos atan sinh cosh tanh asinh acosh
+ sin cos tan asin acos atan sinh cosh tanh asinh acosh
+ atanh sqrt expt integer-expt))
+
+(define *interpreter-defined-vars* '())
+;; '(*features*
+;; most-positive-fixnum most-negative-fixnum))
+
+;; defs in *extra-hobbit-primitive-defs* are used when the extra primitive
+;; is passed as an argument.
+
+(define *extra-hobbit-dot-primitives* '(%+ %- %* %/ %= %< %> %<= %>=))
+
+(define *extra-hobbit-primitive-defs*
+ '((logsleft (lambda (x y) (**return** (ash x y))))
+ (logsright (lambda (x y) (**return** (ash x (- y)))))
+ (%+ (lambda (x)
+ (let* ((r 0))
+ (do ((l x (cdr x))) ((null? l) (**return** r))
+ (set! r (%+ r (car l)))))))
+ (%- (lambda (x)
+ (let* ((r 0))
+ (do ((l x (cdr x))) ((null? l) (**return** r))
+ (set! r (%- r (car l)))))))
+ (%* (lambda (x)
+ (let* ((r 1))
+ (do ((l x (cdr x))) ((null? l) (**return** r))
+ (set! r (%* r (car l)))))))
+ (%/ (lambda (x)
+ (let* ((r 1))
+ (do ((l x (cdr x))) ((null? l) (**return** r))
+ (set! r (%/ r (car l)))))))
+ (%= (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%= (car l) (cadr l)))
+ (set! r #f))))))
+ (%< (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%< (car l) (cadr l)))
+ (set! r #f))))))
+ (%> (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%> (car l) (cadr l)))
+ (set! r #f))))))
+ (%>= (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%>= (car l) (cadr l)))
+ (set! r #f))))))
+ (%<= (lambda (x)
+ (let* ((r #t))
+ (do ((l x (cdr x)))
+ ((or (not r) (null? l) (null? (cdr l))) (**return** r))
+ (if (not (%<= (car l) (cadr l)))
+ (set! r #f))))))))
+
+(define *switch-args-table*
+ '((char>? char<?) (char-ci>? char-ci<?)
+ (char>=? char<=?) (char-ci>=? char-ci<=?)
+ (string>? string<?) (string-ci>? string-ci<?)
+ (string-ci>=? string-ci<=?) (string>=? string<=?)))
+
+(define *add-args-table*
+ (append
+ (list
+ (list 'make-vector '() 2)
+ (list 'number->string (list *num-c->s* 10) 2)
+ (list 'string->number (list *num-c->s* 10) 2)
+ (list 'make-string (list *actual-c-expr* "MAKICHR(' ')") 2))
+ '((quit 1 1)
+ (read (current-input-port) 1)
+ (read-char (current-input-port) 1)
+ (peek-char (current-input-port) 1)
+ (write (current-output-port) 2)
+ (display (current-output-port) 2)
+ (newline (current-output-port) 1)
+ (write-char (current-output-port) 2))))
+
+(define *standard-s->c-fun-table*
+ (append
+ (list (list 'force (symbol->string *force-function*) 1))
+ '((%eqv? "==" 2 #t #t)
+ (%zero? "ZERO_P" 1 #f #t)
+ (%positive? "POSITIVE_P" 1 #f #t)
+ (%negative? "NEGATIVE_P" 1 #f #t)
+ (%= "==" 2 #t #t)
+ (%< "<" 2 #t #t)
+ (%> ">" 2 #t #t)
+ (%<= "<=" 2 #t #t)
+ (%>= ">=" 2 #t #t)
+ (%+ "+" 2 #t #t)
+ (%- "-" 2 #t #t)
+ (%* "*" 2 #t #t)
+ (%/ "lquotient" 2 #f #f)
+ (cons "cons" 2) (car "CAR" 1) (cdr "CDR" 1)
+ (acons "acons" 3)
+ (list? "listp" 1) (length "length" 1) (append "append2" 2)
+ (reverse "reverse" 1) (list-tail "list_tail" 2) (list-ref "list_ref" 2)
+ (memq "memq" 2) (member "member" 2) (memv "memv" 2)
+ (assq "assq" 2) (assv "assv" 2) (assoc "assoc" 2)
+
+ (symbol->string "symbol2string" 1) (string->symbol "string2symbol" 1)
+ (system "lsystem" 1)
+ (verbose "prolixity" 1)
+ (copy-tree "copytree" 1)
+ (@copy-tree "copytree" 1)
+
+ (exact? "exactp" 1) (inexact? "inexactp" 1)
+ (odd? "oddp" 1) (even? "evenp" 1) (max "lmax" 2) (min "lmin" 2) (abs "absval" 1)
+ (quotient "lquotient" 2) (remainder "lremainder" 2)
+ (modulo "modulo" 2) (gcd "lgcd" 2) (lcm "llcm" 2)
+
+ (exact->inexact "EX2IN_FUN" 1) (floor "FLOOR_FUN" 1)
+ (ceiling "CEILING_FUN" 1)
+ (truncate "TRUNCATE_FUN" 1) (round "ROUND_FUN" 1)
+ ($sin "SIN_FUN" 1) ($cos "COS_FUN" 1) ($tan "TAN_FUN" 1)
+ ($asin "ASIN_FUN" 1)
+ ($acos "ACOS_FUN" 1) ($atan "ATAN_FUN" 1) ($sinh "SINH_FUN" 1)
+ ($cosh "COSH_FUN" 1)
+ ($tanh "TANH_FUN" 1) ($asinh "ASINH_FUN" 1) ($acosh "ACOSH_FUN" 1)
+ ($atanh "ATANH_FUN" 1)
+ ($sqrt "SQRT_FUN" 1) ($expt "EXPT_FUN" 2)
+ ($log "LOG_FUN" 1) ($abs "ABS_FUN" 1) ($exp "EXP_FUN" 1)
+
+ (inexact->exact "in2ex" 1)
+ (make-rectangular "makrect" 2) (make-polar "makpolar" 2)
+ (real-part "real_part" 1) (imag-part "imag_part" 1)
+ (magnitude "magnitude" 1) (angle "angle" 1)
+
+ (number->string "number2string" 2) (string->number "string2number" 1)
+
+ (char<? "CHAR_LESSP" 2) (char<=? "CHAR_LEQP" 2)
+ (char-ci=? "CHCI_EQ" 2) (char-ci<? "CHCI_LESSP")
+ (char-ci<=? "CHCI_LEQP" 2)
+
+ (char-alphabetic? "CHAR_ALPHAP" 1) (char-numeric? "CHAR_NUMP" 1)
+ (char-whitespace? "CHAR_WHITEP" 1) (char-upper-case? "CHAR_UPPERP" 1)
+ (char-lower-case? "CHAR_LOWERP" 1)
+
+ (char->integer "CHAR2INT" 1) (integer->char "INT2CHAR" 1)
+ (char-upcase "CHAR_UPCASE" 1) (char-downcase "CHAR_DOWNCASE" 1)
+
+ (make-string "make_string" 2)
+ (string "string" 1)
+ (string-length "ST_LENGTH" 1)
+ (string-ref "ST_REF" 2)
+ (string-set! "st_set" 3)
+ (substring "substring" 3)
+ (string-append "st_append" 1)
+ (list->string "string" 1)
+ (string->list "string2list" 1)
+ (string-copy "string_copy" 1)
+ (string-fill! "string_fill" 2)
+ (string=? "st_equal" 2) (string<? "st_lessp" 2) (string<=? "st_leqp" 2)
+ (string-ci=? "stci_equal" 2) (string-ci<? "stci_lessp")
+ (string-ci<=? "stci_leqp" 2)
+
+ (make-vector "make_vector" 2)
+ (vector "vector" 1)
+ (vector-length "VECTOR_LENGTH" 1)
+
+ (vector-ref "vector_ref" 2)
+ (vector-set! "vector_set" 3)
+ (vector->list "vector2list" 1)
+ (list->vector "vector" 1)
+
+ (read "lread" 1)
+ (read-char "scm_read_char" 1)
+ (peek-char "peek_char" 1)
+ (eof-object? "eof_objectp" 1)
+ (write "lwrite" 2)
+ (display "display" 2)
+ (newline "newline" 1)
+ (write-char "write_char" 2)
+
+ (input-port? "input_portp" 1)
+ (output-port? "output_portp" 1)
+ (current-input-port "cur_input_port" 0)
+ (current-output-port "cur_output_port" 0)
+ (close-input-port "close_port" 1)
+ (close-output-port "close_port" 1)
+
+ (get-internal-run-time "my_time" 0)
+ (quit "quit" 1)
+ (abort "abrt" 0)
+ (restart "restart" 0)
+ (chdir "chdir" 1)
+ (delete-file "del_fil" 1)
+ (rename-file "ren_fil" 2))))
+
+
+ ;;; (<s-fn> <c-fn> <nr-args> <infix-flag> <c-flag>)
+
+(define *reckless-s->c-fun-table*
+ (append
+
+ (if *badivsgns-flag*
+ '()
+ '((quotient "/" 2 #t #t)
+ (remainder "%" 2 #t #t)
+ (/ "/" 2 #t #t)))
+
+ (list
+ (list *sysapply* "apply" 3 #f #f)
+ (list *make-cclo* "makcclo" 2 #f #f)
+ (list *global-access* "GLOBAL" 1 #f #f)
+ (list *velts-function* "VELTS" 1 #f #f)
+ (list *st-vector-ref* "STBL_VECTOR_REF" 2 #f #f)
+ (list *st-vector-set* "STBL_VECTOR_SET" 3 #f #f)
+ (list *not?* "!" 1 #f #t)
+ (list *and?* "&&" 2 #t #t)
+ (list *or?* "||" 2 #t #t)
+ (list *open-file-function* "open_file" 2 #f #f)
+ (list *set-current-input-port-function* "set_inp" 1 #f #f)
+ (list *set-current-output-port-function* "set_outp" 1 #f #f)
+ (list *num-s->c* "INUM" 1 #f #f)
+ (list *num-c->s* "MAKINUM" 1 #f #f)
+ (list *bool-s->c* "NFALSEP" 1 #f #f)
+ (list *bool-c->s* "SBOOL" 1 #f #f)
+ (list *char-c->s* "MAKICHR" 1 #f #f))
+
+ '((boolean? "BOOLEAN_P" 1 #f #t)
+ (symbol? "SYMBOL_P" 1 #f #t)
+ (char? "CHAR_P" 1 #f #t)
+ (vector? "VECTOR_P" 1 #f #t)
+ (pair? "PAIR_P" 1 #f #t)
+ (number? "NUMBER_P" 1 #f #t)
+ (complex? "NUMBER_P" 1 #f #t)
+ (real? "NUMBER_P" 1 #f #t)
+ (rational? "NUMBER_P" 1 #f #t)
+ (integer? "INTEGER_P" 1 #f #t)
+ (string? "STRING_P" 1 #f #t)
+ (procedure? "procedurep" 1 #f #t)
+
+ (not "NOT" 1 #f #f)
+ (eq? "==" 2 #t #t)
+ (eqv? "==" 2 #t #t)
+ (char=? "==" 2 #t #t)
+ (null? "NULL_P" 1 #f #t)
+ (zero? "ZERO_P" 1 #f #t)
+ (positive? "POSITIVE_P" 1 #f #t)
+ (negative? "NEGATIVE_P" 1 #f #t)
+
+ (logand "&" 2 #t #t)
+ (logior "|" 2 #t #t)
+ (logxor "^" 2 #t #t)
+ (lognot "~" 1 #f #t)
+ (logsleft "<<" 2 #t #t)
+ (logsright ">>" 2 #t #t)
+
+ (= "==" 2 #t #t)
+ (< "<" 2 #t #t)
+ (> ">" 2 #t #t)
+ (<= "<=" 2 #t #t)
+ (>= ">=" 2 #t #t)
+
+ (+ "+" 2 #t #t)
+ (- "-" 2 #t #t)
+ (* "*" 2 #t #t)
+
+ (/ "lquotient" 2 #f #f)
+ (set-car! "SET_CAR" 2 #f #t)
+ (set-cdr! "SET_CDR" 2 #f #t)
+ (vector-set! "VECTOR_SET" 3 #f #t)
+ (vector-ref "VECTOR_REF" 2 #f #t)
+
+ (equal? "equal" 2))
+
+ *standard-s->c-fun-table*))
+
+(define *floats-s->c-fun-table*
+ (append
+
+ (list
+ (list *sysapply* "apply" 3 #f #f)
+ (list *make-cclo* "makcclo" 2 #f #f)
+ (list *global-access* "GLOBAL" 1 #f #f)
+ (list *velts-function* "VELTS" 1 #f #f)
+ (list *st-vector-ref* "STBL_VECTOR_REF" 2 #f #f)
+ (list *st-vector-set* "STBL_VECTOR_SET" 3 #f #f)
+ (list *not?* "!" 1 #f #t)
+ (list *and?* "&&" 2 #t #t)
+ (list *or?* "||" 2 #t #t)
+ (list *open-file-function* "open_file" 2 #f #f)
+ (list *set-current-input-port-function* "set_inp" 1 #f #f)
+ (list *set-current-output-port-function* "set_outp" 1 #f #f)
+ (list *num-s->c* "INUM" 1 #f #f)
+ (list *num-c->s* "MAKINUM" 1 #f #f)
+ (list *bool-s->c* "NFALSEP" 1 #f #f)
+ (list *bool-c->s* "SBOOL" 1 #f #f)
+ (list *char-c->s* "MAKICHR" 1 #f #f))
+
+ '((boolean? "BOOLEAN_P" 1 #f #t)
+ (symbol? "SYMBOL_P" 1 #f #t)
+ (char? "CHAR_P" 1 #f #t)
+ (vector? "VECTOR_P" 1 #f #t)
+ (pair? "PAIR_P" 1 #f #t)
+ (number? "NUMBERP" 1 #f #t) ;;; diff from the int case; scm.h macro
+ (complex? "NUMBERP" 1 #f #t) ;;; not in the int case; scm.h macro
+ (real? "realp" 1 #f #t) ;;; not in the int case;
+ (rational? "realp" 1 #f #t) ;;; not for int; ONLY for FLOATS
+ (integer? "intp" 1 #f #t) ;;; not for int; ONLY for FLOATS
+ (string? "STRING_P" 1 #f #t)
+ (procedure? "procedurep" 1 #f #t)
+
+ (not "NOT" 1 #f #f)
+ (eq? "==" 2 #t #t)
+ (eqv? "eqv" 2 #f #t);; diff for int
+ (char=? "==" 2 #t #t)
+ (null? "NULL_P" 1 #f #t)
+ (zero? "zerop" 1 #f #t);; diff for int
+ (positive? "positivep" 1 #f #t);; diff for int
+ (negative? "negativep" 1 #f #t);; diff for int
+
+ (logand "&" 2 #t #t)
+ (logior "|" 2 #t #t)
+ (logxor "^" 2 #t #t)
+ (lognot "~" 1 #f #t)
+ (logsleft "<<" 2 #t #t)
+ (logsright ">>" 2 #t #t)
+
+ (= "eqp" 2 #f #t);; diff for int
+ (< "lessp" 2 #f #t);; diff for int
+ (> "greaterp" 2 #f #t);; diff for int
+ (<= "leqp" 2 #f #t);; diff for int
+ (>= "greqp" 2 #f #t);; diff for int
+
+ (+ "sum" 2 #f #t);; diff for int
+ (- "difference" 2 #f #t);; diff for int
+ (* "product" 2 #f #t);; diff for int
+
+ (/ "divide" 2 #f #f);; diff for int
+ (quotient "lquotient" 2 #f #f)
+ (remainder "lremainder" 2 #f #f)
+
+ (set-car! "SET_CAR" 2 #f #t)
+ (set-cdr! "SET_CDR" 2 #f #t)
+ (vector-set! "VECTOR_SET" 3 #f #t)
+ (vector-ref "VECTOR_REF" 2 #f #t)
+
+ (equal? "equal" 2))
+
+ *standard-s->c-fun-table*))
+
+
+(define (primitive? fn)
+ (or (member fn *cxr-funs*)
+ (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*))
+ (assq fn *switch-args-table*)
+ (assq fn *add-args-table*)
+ (member fn '(list append cond case do let let* letrec define
+ if and or map for-each))))
+
+(define (fixed-arity-primitive? fn)
+ (or (member fn *cxr-funs*)
+ (and (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*))
+ (not (assq fn *associative-fun-table*))
+ (not (assq fn *comparison-fun-table*))
+ (not (assq fn *add-args-table*))
+ (not (member fn '(list append cond case do let let* letrec
+ define if and or map for-each
+ < > <= = >= + * - /
+ %< %> %<= %= %>= %+ %* %- %/ ))))
+ (assq fn *switch-args-table*)))
+
+(define (primitive-arity fn)
+ (let ((tmp (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*))))
+ (cond (tmp (caddr tmp))
+ ((memq fn *cxr-funs*) 1)
+ (else #f))))
+
+;===================================================================
+;
+; introducing type conversion,
+; collecting constants,
+; moving variables to top-let.
+;
+;===================================================================
+
+
+(define (type-const-wholedef term)
+ (set! *local-vars* '())
+ (set! *local-parameters*
+ (map (lambda (x) (if (pair? x) (cadr x) x))
+ (cadr (caddr term))))
+ (set! *current-fun-name* (cadr term))
+ (let* ((tmp (map type-const-pass (cddr (caddr term))))
+ (tmp2 (list 'lambda
+ (cadr (caddr term))
+ (cons 'let*
+ (cons (map (lambda (x) (list x *dummy*))
+ *local-vars*)
+ (begins->list tmp))))))
+ (list (car term) (cadr term) tmp2)))
+
+
+
+(define (begins->list lst)
+ (let ((res '()))
+ (do ((part lst (cdr part)))
+ ((null? part))
+ (if (and (pair? (car part))
+ (or (eq? 'begin (caar part))
+ (eq? *op-begin* (caar part))))
+ (set! res (append (reverse (begins->list (cdar part))) res))
+ (set! res (cons (car part) res))))
+ (reverse res)))
+
+
+(define (type-const-pass-res term)
+ (cond
+ ((string? term)
+ (make-string-constant term))
+ ((char? term)
+ (list *char-c->s* term))
+ ((vector? term)
+ (make-vector-constant term))
+ ((number? term)
+ (if (and (integer? term)
+ (exact? term)
+ (<= term most-positive-fixnum)
+ (>= term most-negative-fixnum))
+ (list *num-c->s* term)
+ (begin
+ (if (not *floats-flag*)
+ (report-warning
+ "exact arithmetic assumed but a nonexact number encountered: " term))
+ (make-number-constant term))))
+ ((symbol? term)
+ (cond ((or (memq term *local-parameters*)
+ (memq term *local-vars*)
+ (memq term *special-c-vars*)
+ (memq term *special-scm->c-functions*))
+ term)
+ ((memq term *fast-vars-list*)
+ term)
+ ((memq term *interpreter-defined-vars*)
+ (list *global-access* term))
+ ((memq term *global-vars-list*)
+ (list *global-access* term))
+ ((or (member-if (lambda (x) (eq? term (cadr x)))
+ *new-constant-list*)
+ (member-if (lambda (x) (eq? term (cadr x)))
+ *symbol-constant-table*)
+ (in-file-defined? term))
+ term)
+ (else (or (memq term *unknown-vars*)
+ (set! *unknown-vars* (cons term *unknown-vars*)))
+ (list *global-access* (make-unknown-constant term)))))
+ ((boolean? term)
+ (list *bool-c->s* term))
+ ((null? term)
+ '())
+ ((not (pair? term))
+ (report-error "disallowed object: " term))
+ ((eq? *special-pseudoquote* (car term))
+ term)
+ ((eq? *actual-c-string* (car term))
+ term)
+ ((eq? *actual-c-int* (car term))
+ term)
+ ((eq? *actual-c-eval* (car term))
+ term)
+ ((eq? 'quote (car term))
+ (cond ((or (string? (cadr term))
+ (vector? (cadr term))
+ (number? (cadr term))
+ (boolean? (cadr term))
+ (char? (cadr term))
+ (null? (cadr term)))
+ (type-const-pass (cadr term)))
+ ((symbol? (cadr term))
+ (make-symbol-constant (cadr term)))
+ ((pair? (cadr term))
+ (make-pair-constant (cadr term)))
+ (else
+ (report-error "disallowed object: " term))))
+ ((and
+ *reckless-arithmetic-flag*
+ (not (modified-fun? (car term)))
+ (or (memq (car term) *always-num-arg-c-funs*)
+ (and (not *floats-flag*)
+ (memq (car term) *num-arg-c-funs*))))
+ (let* ((tmp (map type-const-pass (cdr term)))
+ (tmp2
+ (cons (car term)
+ (map (lambda (x)
+ (if (and (pair? x)
+ (eq? (car x) *num-c->s*))
+ (cadr x)
+ (list *num-s->c* x)))
+ tmp))))
+ (cond ((memq (car term) *num-res-c-funs*)
+ (list *num-c->s* tmp2))
+ ((memq (car term) '(= < <= > >= %= %< %<= %> %>=))
+ (cond
+ ((and (pair? (cadr tmp2))
+ (pair? (caddr tmp2))
+ (eq? (car (cadr tmp2)) (car (caddr tmp2)))
+ (eq? *num-s->c* (car (cadr tmp2))))
+ (list *bool-c->s*
+ (cons (car term) (map cadr (cdr tmp2)))))
+ ((or (and (not (pair? (cadr tmp2)))
+ (pair? (caddr tmp2)))
+ (and (not (pair? (caddr tmp2)))
+ (pair? (cadr tmp2))))
+ (list *bool-c->s* (cons (car term) tmp)))
+ (else
+ (list *bool-c->s* tmp2))))
+ ((and (not *floats-flag*)
+ (memq (car term) *bool-res-c-funs*))
+ (list *bool-c->s* tmp2))
+ ((memq (car term) *always-bool-res-c-funs*)
+ (list *bool-c->s* tmp2))
+ (else
+ tmp2))))
+ ((and (or (memq (car term) '(eq? char=? %eqv? %=))
+ (and (not *floats-flag*)
+ (or (eq? 'eqv? (car term))
+ (eq? '= (car term)))))
+ (not (modified-fun? (car term))))
+ (let ((tmp (map type-const-pass (cdr term))))
+ (if (and (pair? (car tmp))
+ (memq (caar tmp) *type-converters*)
+ (pair? (cadr tmp))
+ (memq (caadr tmp) *type-converters*))
+ (list *bool-c->s* (cons (car term) (map cadr tmp)))
+ (list *bool-c->s* (cons (car term) tmp)))))
+ ((and (memq (car term) *bool-arg-c-funs*)
+ (not (modified-fun? (car term))))
+ (let* ((tmp (map type-const-pass (cdr term)))
+ (tmp2 (cons (car term) (map c-boolify tmp))))
+ (if (memq (car term) *bool-res-c-funs*)
+ (list *bool-c->s* tmp2)
+ tmp2)))
+ ((and (not *floats-flag*)
+ (memq (car term) *bool-res-c-funs*)
+ (not (modified-fun? (car term))))
+ (list *bool-c->s*
+ (cons (car term) (map type-const-pass (cdr term)))))
+ ((and (memq (car term) *always-bool-res-c-funs*)
+ (not (modified-fun? (car term))))
+ (list *bool-c->s*
+ (cons (car term) (map type-const-pass (cdr term)))))
+ ((or (eq? 'if (car term)) (eq? *op-if* (car term)))
+ (let ((tmp (map type-const-pass (cdr term))))
+ (cons (car term)
+ (cons (c-boolify (car tmp)) (cdr tmp)))))
+ ((eq? (car term) 'let*)
+ (set! *local-vars* (union (map car (cadr term)) *local-vars*))
+ (cons 'begin
+ (map type-const-pass
+ (begins->list
+ (append (map (lambda (x) (cons 'set! x)) (cadr term))
+ (cddr term))))))
+ ((eq? (car term) *op-let*)
+ (set! *local-vars* (union (map car (cadr term)) *local-vars*))
+ (cons *op-begin*
+ (map type-const-pass
+ (begins->list
+ (append (map (lambda (x) (cons 'set! x)) (cadr term))
+ (cddr term))))))
+ ((or (eq? 'begin (car term)) (eq? *op-begin* (car term)))
+ (cons (car term)
+ (begins->list (map type-const-pass (cdr term)))))
+ ((eq? (car term) 'do)
+ (set! *local-vars* (union (map car (cadr term)) *local-vars*))
+ (let ((tmp (list* 'do
+ (map (lambda (x) (map type-const-pass x))
+ (cadr term))
+ (map type-const-pass (caddr term))
+ (map type-const-pass (cdddr term)))))
+ (if (null? (cdr (caddr tmp)))
+ (cons *do-not*
+ (begins->list
+ (cons (cadr tmp)
+ (cons (cons (c-negate
+ (c-boolify
+ (car (caddr tmp))))
+ (cdr (caddr tmp)))
+ (cdddr tmp)))))
+ (cons
+ 'begin
+ (begins->list
+ (cons
+ (cons *do-not*
+ (begins->list
+ (cons (cadr tmp)
+ (cons (list
+ (c-negate
+ (c-boolify
+ (car (caddr tmp)))))
+ (cdddr tmp)))))
+ (begins->list (cdr (caddr tmp)))))))))
+ ((eq? *function* (car term))
+ (cond ((or (memq (cadr term) *local-vars*)
+ (memq (cadr term) *local-parameters*))
+ (list *function* (cadr term)))
+ ((memq (cadr term) *top-level-funs*)
+ ; (report-error
+ ; "In " *current-fun-name* " compiled function "
+ ; (cadr term) " occurs as an argument. Use lambdaterm!")
+ (list *function* (cadr term)))
+ ((in-file-defined? (cadr term))
+ (list *function* (cadr term)))
+ (else
+ (report-error
+ "In " *current-fun-name* " interpreted function "
+ (cadr term) " occurs as an argument. Use lambdaterm!"))))
+ ((and (memq (car term) *cxr-funs*)
+ (not (modified-fun? (car term))))
+ (cxr-open (car term) (type-const-pass (cadr term))))
+ ; the following always fails
+ ((begin (set! term (fun-names-to-refs term)) #f))
+ ((unknown-function? (car term) (cdr term))
+ (make-unknown-call term))
+ ((and (eq? (car term) 'vector-set!)
+ (memq (cadr term) *stable-vector-names*))
+ (cons *st-vector-set*
+ (cons (string->symbol
+ (string-append
+ (symbol->string (cadr term))
+ *st-vector-postfix*))
+ (map type-const-pass (cddr term)))))
+ ((and (eq? (car term) 'vector-ref)
+ (memq (cadr term) *stable-vector-names*))
+ (cons *st-vector-ref*
+ (cons (string->symbol
+ (string-append
+ (symbol->string (cadr term))
+ *st-vector-postfix*))
+ (map type-const-pass (cddr term)))))
+ (else
+ (cons (car term)
+ (map type-const-pass (cdr term))))))
+
+(define (type-const-pass term)
+ (define res (type-const-pass-res term))
+ (if (and (pair? res) (or (eq? 'begin (car res))
+ (eq? *op-begin* (car res))))
+ (cons (car res) (begins->list (cdr res)))
+ res))
+
+
+(define (fun-names-to-refs term)
+ (let ((hofdata (assq (car term) *liftable-hof-database*))
+ (tmp '()))
+ (if hofdata
+ (cons (car term)
+ (map (lambda (flag arg)
+ (cond
+ ((not (symbol? arg)) arg)
+ (flag arg)
+ (else (fun-names-to-refs-aux arg))))
+ (cdr hofdata)
+ (cdr term)))
+ (cons (car term)
+ (map (lambda (arg)
+ (if (symbol? arg)
+ (fun-names-to-refs-aux arg)
+ arg))
+ (cdr term))))))
+
+(define (fun-names-to-refs-aux name)
+ (if (and (not (memq name *local-parameters*))
+ (not (memq name *local-vars*))
+ (in-file-defined? name))
+ (let ((newname (make-closure-scmobj-name name)))
+ (if (not (memq name *symbol-and-fun-list*))
+ (begin
+ (set! *var-make-list*
+ (cons `(set!
+ ,(make-closure-scmobj-name name)
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string name))
+ ,(string-length
+ (symbol->string name))))))
+ *var-make-list*))
+ (set! *symbol-and-fun-list* (cons name *symbol-and-fun-list*))))
+ (list *global-access* newname))
+ name))
+
+
+(define (unknown-function? fn args)
+ (let ((len (length args)))
+ (or
+ (pair? fn)
+ (modified-fun? fn)
+ (not
+ (or (let ((tmp (memq fn *prohibited-funs*)))
+ (if tmp
+ (report-error "In " *current-fun-name*
+ " a prohibited function "
+ fn " is called."))
+ #f)
+ (eq? fn *current-fun-name*)
+ (memq fn *special-scm->c-functions*)
+ (assq fn *switch-args-table*)
+ (assq fn *add-args-table*)
+ (memq fn '(vector string if begin let* lambda set!))
+ (memq fn *internal-c-functions*)
+ (let ((tmp (if *floats-flag*
+ (assq fn *floats-s->c-fun-table*)
+ (assq fn *reckless-s->c-fun-table*))))
+ (if (and tmp (not (eqv? len (caddr tmp))))
+ (report-error "In " *current-fun-name* " function "
+ fn " is called with a wrong nr of args."))
+ tmp)
+ (let ((tmp (member-if (lambda (x) (eq? fn (cadr x)))
+ *to-do-fun-list*)))
+ (if (and tmp (not (eqv? len (length (cadr (caddar tmp))))))
+ (if (memq fn *top-level-funs*)
+ (report-error "In " *current-fun-name* " function "
+ fn " is called with a wrong nr of args.")
+ (report-error "In " *current-fun-name* " function "
+ fn
+ " is called with a wrong nr of args or builds closures.")))
+ tmp)
+ (let ((tmp (member-if (lambda (x) (eq? fn (cadr x))) *passed-defs*)))
+ (if (and tmp (not (eqv? len (length (cadr (caddar tmp))))))
+ (if (memq fn *top-level-funs*)
+ (report-error "In " *current-fun-name* " function "
+ fn " is called with a wrong nr of args.")
+ (report-error "In " *current-fun-name* " function "
+ fn
+ " is called with a wrong nr of args or builds closures.")))
+ tmp)
+ (memq fn *top-level-funs*))))))
+
+
+(define (in-file-defined? fn)
+ (or (memq fn *top-level-funs*)
+ (eq? fn *current-fun-name*)
+ (member-if (lambda (x) (eq? fn (cadr x))) *to-do-fun-list*)
+ (member-if (lambda (x) (eq? fn (cadr x))) *passed-defs*)))
+
+(define (top-nonlist-in-file-defined? fn)
+ (let ((x (or (member-if
+ (lambda (x) (or (eq? fn (cadr x))
+ (and (pair? (cadr x)) (eq? fn (caadr x)))))
+ *to-do-fun-list*)
+ (member-if
+ (lambda (x) (or (eq? fn (cadr x))
+ (and (pair? (cadr x)) (eq? fn (caadr x)))))
+ *passed-defs*))))
+ (and x
+ (let ((y (car x)))
+ (if (pair? (cadr y))
+ (list? (cadr y))
+ (and (pair? (cddr y))
+ (pair? (caddr y))
+ (eq? 'lambda (car (caddr y)))
+ (pair? (cdr (caddr y)))
+ (list? (cadr (caddr y)))))))))
+
+(define (make-unknown-call term)
+ (let* ((fn (car term))
+ (args1 (map type-const-pass (cdr term)))
+ (args (map make-interpreter-usable args1))
+ (glob '()))
+ (if (pair? fn)
+ (set! glob (type-const-pass (car term)))
+ (if (or (memq fn *special-c-vars*)
+ (memq fn *local-parameters*)
+ (memq fn *local-vars*))
+ (set! glob fn)
+ (set! glob (list *global-access* (make-unknown-constant fn)))))
+ (or (pair? fn)
+ (memq fn *special-c-vars*)
+ (memq fn *local-parameters*)
+ (memq fn *local-vars*)
+ (memq fn *unknown-functions*)
+ (set! *unknown-functions* (cons fn *unknown-functions*)))
+ (list *sysapply*
+ glob
+ (if (null? args) '() (car args))
+ (if (null? args)
+ '()
+ (make-apply-second-arg (cdr args))))))
+
+(define (make-unknown-call-aux term args)
+ (let ((fn (caar term)))
+ (if (or (in-file-defined? fn)
+ (memq fn *prohibited-funs*))
+ (report-error "In " *current-fun-name* " function "
+ fn " is assumed to return a closure.")
+ (make-unknown-call (car term)))))
+
+
+(define (make-interpreter-usable term)
+ (let ((fn (if (pair? term)
+ (if (and (eq? *global-access* (car term))
+ (in-file-defined? (cadr term)))
+ (cadr term)
+ #f)
+ (if (and (symbol? term)
+ (in-file-defined? term))
+ term
+ #f)))
+ (tmp '()))
+ (if (not fn)
+ term
+ (make-interpreter-funname fn))))
+
+
+(define (make-interpreter-funname fn)
+ (let ((tmp (assq fn *interpreter-funname-table*)))
+ (if tmp
+ (cdr tmp)
+ (begin
+ (set! tmp
+ (string->symbol
+ (string-append (symbol->string fn) *interpreter-suffix*)))
+ (set! *interpreter-funname-table*
+ (cons (cons fn tmp) *interpreter-funname-table*))
+ (list *global-access* tmp)))))
+
+(define (make-unknown-constant var)
+ (if (memq var *global-vars-list*)
+ var
+ (begin
+ (set! *global-vars-list* (cons var *global-vars-list*))
+ (set! *var-make-list*
+ (cons `(set!
+ ,var
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string var))
+ ,(string-length
+ (symbol->string var))))))
+ *var-make-list*))
+ var)))
+
+(define (make-apply-second-arg args)
+ (if (null? args)
+ *listofnull*
+ (list 'cons
+ (car args)
+ (make-apply-second-arg (cdr args)))))
+
+
+
+(define (make-string-constant str)
+ (let ((name (make-constant-name)))
+ (set! *new-constant-list*
+ (cons (list 'set!
+ name
+ (list 'scm-gc-protect
+ (list *makfromstr-function*
+ (list *actual-c-string* str)
+ (string-length str))))
+ *new-constant-list*))
+ name))
+
+(define (make-number-constant num)
+ (let ((name (make-constant-name))
+ (str (number->string num)))
+ (set! *new-constant-list*
+ (cons (list 'set!
+ name
+ (list 'scm-gc-protect
+ (list *string->number-function*
+ (list *makfromstr-function*
+ (list *actual-c-string* str)
+ (string-length str))
+ (list *num-c->s* 10))))
+ *new-constant-list*))
+ name))
+
+
+(define (make-vector-constant vect)
+ (let* ((name (make-constant-name))
+ (tmp (list 'set!
+ name
+ (list 'scm-gc-protect
+ (list 'list->vector
+ (make-pair-constant-aux
+ (vector->list vect)))))))
+ (set! *new-constant-list* (cons tmp *new-constant-list*))
+ name))
+
+
+(define (make-pair-constant pair)
+ (let* ((name (make-constant-name))
+ (tmp (list 'set!
+ name
+ (list 'scm-gc-protect
+ (list 'cons
+ (make-pair-constant-aux (car pair))
+ (make-pair-constant-aux (cdr pair)))))))
+ (set! *new-constant-list* (cons tmp *new-constant-list*))
+ name))
+
+(define (make-pair-constant-aux term)
+ (if (pair? term)
+ (list 'cons
+ (make-pair-constant-aux (car term))
+ (make-pair-constant-aux (cdr term)))
+ (type-const-pass (list 'quote term))))
+
+(define (make-symbol-constant symb)
+ (let ((tmp (assq symb *symbol-constant-table*)))
+ (if tmp
+ (cadr tmp)
+ (let ((name (make-symbol-name symb))
+ (str (symbol->string symb))
+ (clname '()))
+ ;; if the symb is also a top-level-fun, then avoid
+ ;; applying make_subr to the symbol name string:
+ ;; this would mess up symbol-names table for scm.
+ (if (and (memq symb *top-level-funs*)
+ (not (memq symb *symbol-and-fun-list*)))
+ (begin
+ (set! *var-make-list*
+ (cons `(set!
+ ,(make-closure-scmobj-name symb)
+ (,*c-adr* (cdr (,*intern-function*
+ (,*actual-c-string*
+ ,(symbol->string symb))
+ ,(string-length
+ (symbol->string symb))))))
+ *var-make-list*))
+
+ (set! *symbol-and-fun-list*
+ (cons symb *symbol-and-fun-list*))))
+ (set! *symbol-constant-table*
+ (cons (list symb name) *symbol-constant-table*))
+ (set! *symbol-list*
+ (cons (list 'set!
+ name
+ `(scm-gc-protect
+ (car (,*intern-symbol-function*
+ (,*actual-c-string* ,str)
+ ,(string-length str)))))
+ ;;; (list 'string->symbol
+ ;;; (list 'list->string
+ ;;; (make-pair-constant-aux
+ ;;; (string->list
+ ;;; (symbol->string symb)))))
+ *symbol-list*))
+ name))))
+
+(define (make-constant-name)
+ (set! *new-constant-num* (+ 1 *new-constant-num*))
+ (string->symbol (string-append *new-constant-prefix*
+ (number->string *new-constant-num*))))
+
+
+(define (make-symbol-name symb)
+ (string->symbol (string-append (symbol->string symb)
+ *symbol-name-postfix*)))
+
+(define (c-negate term)
+ (if (and (pair? term) (eq? *not?* (car term)))
+ (cadr term)
+ (list *not?* term)))
+
+(define (cxr-open cxr arg)
+ (let* ((str (symbol->string cxr))
+ (chr #\c)
+ (len (string-length str))
+ (res arg))
+ (do ((n (- len 2) (- n 1)))
+ ((= 0 n))
+ (set! chr (string-ref str n))
+ (set! res
+ (list (if (eqv? #\a chr) 'car 'cdr) res)))
+ res))
+
+
+(define (c-boolify term)
+ (if (and (pair? term) (eq? *bool-c->s* (car term)))
+ (cadr term)
+ (list *bool-s->c* term)))
+
+;===================================================================
+;
+; a pass for
+; correcting higher-order function calls and
+; dotted-arglist function calls.
+;
+;===================================================================
+
+
+(define (ho-dot-wholedef term)
+ (set! *current-fun-name* (cadr term))
+ (ho-dot-pass term))
+
+(define (ho-dot-pass term)
+ (cond ((or (not (pair? term)) (eq? 'quote (car term)))
+ term)
+ ((memq (car term) *dot-arg-funs*)
+ (let* ((template (assq (car term) *dot-arg-templates*))
+ (new (make-listarg-arglist (cadr template) (cdr term))))
+ (if (and (memq (car term) *higher-order-funs*)
+ (liftable-hofname? (car term)))
+ (correct-ho-call
+ (cons (car term) (map ho-dot-pass new)))
+ (cons (car term) (map ho-dot-pass new)))))
+ ((and (memq (car term) *higher-order-funs*)
+ (liftable-hofname? (car term)))
+ (correct-ho-call (map ho-dot-pass term)))
+ (else
+ (map ho-dot-pass term))))
+
+(define (correct-ho-call term)
+ (let* ((add-args '())
+ (stay-args '())
+ (name (car term))
+ (data (assq name *higher-order-templates*))
+ (new-template '()))
+
+ (do ((args (cdr term) (cdr args))
+ (funtemplate (cadr data) (cdr funtemplate)))
+ ((null? args))
+ (if (car funtemplate)
+ (begin
+ (if (and (not (pair? (car args)))
+ (and (primitive? (car args))
+ (if (fixed-arity-primitive? (car args))
+ #t
+ (report-error
+ "in function " *current-fun-name*
+ " a variable-arity primitive is passed to a higher-order fun: " term))))
+ (let*
+ ((tmpargs (reverse
+ (list-tail '(w v u z y x)
+ (- 6 (primitive-arity (car args))))))
+ (newfun
+ (list 'lambda
+ tmpargs
+ (cons (car args) tmpargs)))
+ (newname (make-new-primitive-instname (car args))))
+ (set! *to-do-fun-list*
+ (cons (list 'define newname newfun)
+ *to-do-fun-list*))
+ (set! args (cons newname (cdr args)))))
+ (if (pair? (car args))
+ (begin
+ (set! add-args
+ (append (reverse (cdar args)) add-args))
+ (set! stay-args
+ (cons (caar args) stay-args))
+ (set! new-template
+ (cons (list
+ (length
+ (filter (lambda (x)
+ (or (not (pair? x))
+ (not (eq? *c-adr* (car x)))))
+ (cdar args)))
+ (length
+ (filter (lambda (x)
+ (and (pair? x)
+ (eq? *c-adr* (car x))))
+ (cdar args))))
+ new-template)))
+ (begin
+ (set! new-template (cons (list '0 '0) new-template))
+ (set! stay-args (cons (car args) stay-args)))))
+ (begin
+ (set! new-template (cons '0 new-template))
+ (set! stay-args (cons (car args) stay-args)))))
+
+ (set! new-template (reverse new-template))
+ (set! add-args (reverse add-args))
+ (set! stay-args (reverse stay-args))
+ (let ((attempt (assoc new-template (cddr data))))
+ (if attempt
+ (begin
+ (cons (cadr attempt)
+ (append add-args
+ (map (lambda (x y)
+ (if x (list *function* y) y))
+ (cadr data)
+ stay-args))))
+ (begin
+ (make-new-ho-instance term new-template data add-args stay-args)
+ (let ((attempt2 (assoc new-template (cddr data))))
+ (cons (cadr attempt2)
+ (append add-args
+ (map (lambda (x y)
+ (if x (list *function* y) y))
+ (cadr data)
+ stay-args)))))))))
+
+
+(define (make-new-ho-instance term new-template data add-args stay-args)
+ (let* ((done-mainfun-flag #f)
+ (mainfun-place (member-if (lambda (x) (eq? (cadr x) (car term)))
+ *to-do-fun-list*))
+ (ho-fun (if mainfun-place
+ (begin
+ (set! done-mainfun-flag #f)
+ (car mainfun-place))
+ (begin
+ (set! mainfun-place
+ (member-if (lambda (x) (eq? (cadr x) (car term)))
+ *passed-defs*))
+ (if (not mainfun-place)
+ (report-error "Higher-order function "
+ (car term)
+ " is not defined."))
+ (set! done-mainfun-flag #t)
+ (car mainfun-place))))
+ (dot-data (assq (cadr ho-fun) *dot-arg-templates*))
+ (data (assq (car term) *higher-order-templates*))
+ (ho-term (caddr ho-fun))
+ (new-args '())
+ (new-name (make-new-instname (cadr ho-fun) (length (cddr data)))))
+ (set! *top-level-funs*
+ (cons new-name *top-level-funs*))
+ (set! *make-new-ho-data* '())
+ (for-each (lambda (x y)
+ (if (pair? x)
+ (let ((new (make-new-parameters x)))
+ (set! *make-new-ho-data*
+ (cons (cons (if (pair? y) (cadr y) y)
+ (args->list new))
+ *make-new-ho-data*))
+ (set! new-args
+ (append new new-args)))))
+ new-template
+ (args->list (cadr ho-term)))
+ (if dot-data
+ (begin (set! *dot-arg-funs* (cons new-name *dot-arg-funs*))
+ (set! *dot-arg-templates*
+ (cons (list new-name
+ (append new-args (cadr dot-data)))
+ *dot-arg-templates*))))
+ (set! ho-term (make-new-inst-aux
+ ho-term (args->list new-args) (cadr ho-fun) new-name))
+ (set! ho-term
+ (cons (car ho-term)
+ (cons (append new-args (cadr ho-term))
+ (cddr ho-term))))
+ (set! ho-fun
+ (list (car ho-fun) new-name ho-term))
+ (set-cdr! (my-last-pair data)
+ (list (list new-template (cadr ho-fun))))
+ (if done-mainfun-flag
+ (begin
+ (set-cdr! mainfun-place
+ (cons (car mainfun-place) (cdr mainfun-place)))
+ (set-car! mainfun-place ho-fun))
+ (begin
+ (set-cdr! mainfun-place
+ (cons ho-fun (cdr mainfun-place)))))))
+
+(define (make-new-instname genname nr)
+ (let ((name
+ (string->symbol
+ (string-append (symbol->string genname)
+ *new-instfun-infix*
+ (number->string nr)))))
+ name))
+
+(define (make-new-primitive-instname genname)
+ (set! *new-primitive-instnr* (+ 1 *new-primitive-instnr*))
+ (let ((name
+ (string->symbol
+ (string-append (symbol->string genname)
+ *new-instfun-infix*
+ (number->string *new-primitive-instnr*)))))
+ name))
+
+(define (make-new-inst-aux term n-args o-name n-name)
+ (let ((tmp #f))
+ (cond ((or (not (pair? term)) (eq? 'quote (car term))) term)
+ ((eq? *higher-order-call* (car term))
+ (set! tmp (assq (cadr term) *make-new-ho-data*))
+ (if tmp
+ (cons (car term)
+ (cons (cadr term)
+ (if (null? (cdr tmp))
+ (cddr term)
+ (append (cdr tmp) (cddr term)))))
+ (map (lambda (x) (make-new-inst-aux x n-args o-name n-name))
+ term)))
+ ((eq? (car term) 'lambda)
+ (cons (car term)
+ (cons (cadr term)
+ (map (lambda (x)
+ (make-new-inst-aux x n-args o-name n-name))
+ (cddr term)))))
+ ((eq? (car term) o-name)
+ (cons n-name
+ (append
+ n-args
+ (map (lambda (x)
+ (make-new-inst-aux x n-args o-name n-name))
+ (cdr term)))))
+ (else
+ (map (lambda (x) (make-new-inst-aux x n-args o-name n-name))
+ term)))))
+
+
+(define (make-new-parameters nums)
+ (let* ((vars1 '())
+ (vars2 '()))
+ (do ((n (car nums) (- n 1)))
+ ((zero? n))
+ (set! vars1 (cons (make-new-parameter) vars1)))
+ (do ((n (cadr nums) (- n 1)))
+ ((zero? n))
+ (set! vars2 (cons (list *c-adr* (make-new-parameter)) vars2)))
+ (set! vars1 (reverse vars1))
+ (set! vars2 (reverse vars2))
+ (append vars1 vars2)))
+
+(define (make-new-parameter)
+ (set! *new-parameter-nr* (+ 1 *new-parameter-nr*))
+ (string->symbol (string-append *new-parameter-prefix*
+ (number->string *new-parameter-nr*))))
+
+
+
+;===================================================================
+;
+; statement-lifting & tail-recursion
+;
+;===================================================================
+
+
+(define (lift-statements-wholedef defterm)
+ (set! *current-fun-name* (cadr defterm))
+ (set! *tailrec-flag* #f)
+ (set! *higher-order-flag* #f)
+ (let ((res '())
+ (res2 '())
+ (newname #f)
+ (tmp '())
+ (lambdaterm (caddr defterm)))
+ (set! *higher-order-args* (args->list (cadr lambdaterm)))
+ (set! *current-formal-args* (cadr lambdaterm))
+ (set! *current-formal-argslist* (args->list (cadr lambdaterm)))
+ (set! res (lift-statements lambdaterm '()))
+ (if (not (list? (cadr lambdaterm)))
+ (begin
+ (set! *dot-arg-funs*
+ (cons (cadr defterm) *dot-arg-funs*))
+ (set! *dot-arg-templates*
+ (cons (list (cadr defterm)
+ (cadr lambdaterm))
+ *dot-arg-templates*))))
+ (if (and *higher-order-flag*
+ (liftable-hofname? (cadr defterm)))
+ (begin
+ (set! *higher-order-args*
+ (map (lambda (x) (if (eq? x '#t) '#t '#f))
+ *higher-order-args*))
+ (set! *higher-order-funs*
+ (cons (cadr defterm) *higher-order-funs*))
+ (set! *higher-order-templates*
+ (cons
+ (list (cadr defterm)
+ *higher-order-args*
+ (list (map (lambda (x)
+ (if x (list '0 '0) '0))
+ *higher-order-args*)
+ (cadr defterm)))
+ *higher-order-templates*))
+ (if (and (memq *current-fun-name* *top-level-funs*)
+ (not (null? *export-functions*))
+ (or (not (pair? *export-functions*))
+ (memq *current-fun-name* *export-functions*)))
+ (begin
+ (set! newname
+ (string->symbol
+ (string-append (symbol->string *current-fun-name*)
+ *export-hof-postfix*)))
+ (set! *top-level-funs*
+ (cons newname *top-level-funs*))
+ (set! *export-table*
+ (cons (list *current-fun-name* newname)
+ *export-table*))
+ (set! tmp (assq *current-fun-name* *dot-arg-templates*))
+ (if tmp
+ (begin
+ (set! *dot-arg-templates*
+ (cons (list newname (cadr tmp))
+ *dot-arg-templates*))
+ (set! *dot-arg-funs*
+ (cons newname *dot-arg-funs*))))
+ (set! res2
+ (make-export-hof res))))
+ (set! res (cons (car res)
+ (cons (map (lambda (x y)
+ (if x (list *function* y) y))
+ *higher-order-args*
+ (maklist (cadr res)))
+ (cddr res))))))
+ (if *tailrec-flag*
+ (begin
+ (set! res (cons (car res)
+ (cons (cadr res)
+ (cons (list *mark-tailrec*)
+ (cddr res)))))
+ (if (not (null? res2))
+ (set! res2 (cons (car res2)
+ (cons (cadr res2)
+ (cons (list *mark-tailrec*)
+ (cddr res2))))))))
+ (set! res
+ (list 'define (cadr defterm)
+ (if (list? (cadr res))
+ res
+ (cons (car res)
+ (cons (maklist (cadr res))
+ (cddr res))))))
+ (if (null? res2)
+ (list res)
+ (list res
+ (list 'define newname
+ (if (list? (cadr res2))
+ res2
+ (cons (car res2)
+ (cons (maklist (cadr res2))
+ (cddr res2)))))))))
+
+
+(define (maklist args)
+ (cond ((symbol? args)
+ (list args))
+ ((null? args)
+ '())
+ (else (cons (car args) (maklist (cdr args))))))
+
+
+(define (make-export-hof term)
+ (cond ((or (not (pair? term))
+ (eq? 'quote (car term)))
+ term)
+ ((eq? 'lambda (car term))
+ (cons (car term)
+ (cons (cadr term)
+ (map make-export-hof (cddr term)))))
+ ((eq? (car term) *higher-order-call*)
+ (list *sysapply*
+ (cadr term)
+ (if (null? (cddr term))
+ '()
+ (make-export-hof (caddr term)))
+ (if (null? (cddr term))
+ '()
+ (make-apply-second-arg
+ (make-export-hof (cdddr term))))))
+ ((eq? (car term) *function*)
+ (cadr term))
+ ((eq? (car term) *current-fun-name*)
+ (cons (string->symbol
+ (string-append (symbol->string *current-fun-name*)
+ *export-hof-postfix*))
+ (map make-export-hof (cdr term))))
+ (else
+ (map make-export-hof term))))
+
+
+(define (lift-statements term checkvars)
+ (cond
+ ((or (not (pair? term)) (eq? 'quote (car term)))
+ term)
+ ((eq? 'lambda (car term))
+ (set! checkvars (args->list (cadr term)))
+ (append
+ (list 'lambda)
+ (list (cadr term))
+ (map (lambda (x) (lift-statements x checkvars))
+ (butlast (cddr term) 1))
+ (list
+ (lift-statements
+ (push-result-var-in *return* (car (my-last-pair term)))
+ checkvars))))
+ ((and (eq? 'set! (car term))
+ (or (null? (cdr term)) (null? (cddr term))))
+ (report-error
+ " scheme syntax in fun " *current-fun-name* ": " term))
+ ((and (eq? 'set! (car term))
+ (pair? (caddr term))
+ (memq (caaddr term) '(do if begin let*)))
+ (lift-statements (push-result-var-in (cadr term) (caddr term))
+ checkvars))
+ ((eq? 'do (car term))
+ (set! checkvars (union (map car (cadr term)) checkvars))
+ (list* 'do
+ (map
+ (lambda (x)
+ (map (lambda (y) (lift-stat-aux y checkvars)) x))
+ (cadr term))
+ (append (list
+ (lift-stat-aux (car (caddr term)) checkvars))
+ (map (lambda (x)
+ (lift-statements x checkvars))
+ (cdr (caddr term))))
+ (map (lambda (x) (lift-statements x checkvars))
+ (cdddr term))))
+ ((eq? 'if (car term))
+ (if (eq? 3 (length term))
+ (list 'if
+ (lift-stat-aux (cadr term) checkvars)
+ (lift-statements (caddr term) checkvars))
+ (list 'if
+ (lift-stat-aux (cadr term) checkvars)
+ (lift-statements (caddr term) checkvars)
+ (lift-statements (cadddr term) checkvars))))
+ ((eq? 'begin (car term))
+ (append (list 'begin)
+ (map (lambda (x)
+ (lift-statements
+ (if (and (pair? x) (eq? 'set! (car x)))
+ (push-result-var-in (cadr x) (caddr x))
+ x)
+ checkvars))
+ (cdr term))))
+ ((or (eq? 'let* (car term)) (eq? 'let (car term)))
+ (set! checkvars (union (map car (cadr term)) checkvars))
+ (append (list 'let*)
+ (list (map (lambda (x) (list (car x) *dummy*)) (cadr term)))
+ (map (lambda (x)
+ (lift-statements
+ (push-result-var-in (car x) (cadr x))
+ checkvars))
+ (cadr term))
+ (map (lambda (x) (lift-statements x checkvars))
+ (cddr term))))
+ ((and (eq? 'set! (car term))
+ (pair? (caddr term))
+ (memq (caaddr term) '(do if begin let*)))
+ (lift-statements (push-result-var-in (cadr term) (caddr term))
+ checkvars))
+ (else
+ (lift-stat-aux term checkvars))))
+
+
+
+(define (lift-stat-aux term checkvars)
+ (cond
+ ((or (not (pair? term)) (eq? 'quote (car term)))
+ term)
+ ((eq? (car term) 'if)
+ (if (and *lift-ifs-flag*
+ (or (lift-if-arg? (caddr term))
+ (and (not (null? (cdddr term)))
+ (lift-if-arg? (cadddr term)))))
+ (let ((argvars (free-vars term checkvars '()))
+ (newname (new-fun-name *current-fun-name*)))
+ (set! *to-do-fun-list*
+ (cons
+ (list 'define
+ newname
+ (list 'lambda
+ (make-arglist argvars '())
+ (fetchify (cadr argvars) term)))
+ *to-do-fun-list*))
+ (cons newname (make-arglist argvars '())))
+ (cons *op-if* (map (lambda (x) (lift-stat-aux x checkvars))
+ (cdr term)))))
+ ((eq? (car term) 'begin)
+ (cons *op-begin* (map (lambda (x) (lift-stat-aux x checkvars))
+ (cdr term))))
+ ((or (eq? (car term) 'let*) (eq? (car term) 'let))
+ (set! checkvars (union (map car (cadr term)) checkvars))
+ (append (list *op-let*)
+ (list (map (lambda (x) (lift-stat-aux x checkvars))
+ (cadr term)))
+ (map (lambda (x) (lift-stat-aux x checkvars))
+ (cddr term))))
+ ((eq? (car term) 'do)
+ (let ((argvars (free-vars term checkvars '()))
+ (newname (new-fun-name *current-fun-name*)))
+ (set! *to-do-fun-list*
+ (cons
+ (list 'define
+ newname
+ (list 'lambda
+ (make-arglist argvars '())
+ (fetchify (cadr argvars) term)))
+ *to-do-fun-list*))
+ (cons newname (make-arglist argvars '()))))
+ ((and (memq (car term) *current-formal-argslist*)
+ (liftable-hofname? *current-fun-name*))
+ (set! *higher-order-flag* #t)
+ (set! *higher-order-args*
+ (replaceq (car term) '#t *higher-order-args*))
+ (cons *higher-order-call*
+ (map (lambda (x) (lift-stat-aux x checkvars)) term)))
+ (else
+ (map (lambda (x) (lift-stat-aux x checkvars)) term))))
+
+
+;;; lift-if-arg? says whether it is needed/sensible to lift
+;;; the if-statement with such a <term> as one of the resulting args
+
+(define (lift-if-arg? term)
+ (and (pair? term)
+ (not (eq? 'quote (car term)))
+ (not (and (memq
+ (car term)
+ (cons *not?*
+ (cons *and?*
+ (cons *or?*
+ '(eq? = < > <= >=
+ number? boolean? null? pair? zero?
+ character? vector?
+ %= %< %> %<= %>=
+ %eqv? %number? %zero)))))
+ (not (member-if (lambda (x) (pair? x)) (cdr term)))))))
+
+
+(define (push-result-var-in var term)
+ (cond ((or (not (pair? term)) (eq? 'quote (car term)))
+ (if (eq? var *return*)
+ (list *return* term)
+ (list 'set! var term)))
+ ((eq? (car term) 'if)
+ (if (eq? 3 (length term))
+ (list 'if (cadr term)
+ (push-result-var-in var (caddr term)))
+ (list 'if (cadr term)
+ (push-result-var-in var (caddr term))
+ (push-result-var-in var (cadddr term)))))
+ ((eq? (car term) 'begin)
+ (append (list 'begin)
+ (butlast (cdr term) 1)
+ (list (push-result-var-in var
+ (car (my-last-pair term))))))
+ ((or (eq? (car term) 'let*) (eq? (car term) 'let))
+ (append (list 'let*)
+ (list (cadr term))
+ (butlast (cddr term) 1)
+ (list (push-result-var-in var
+ (car (my-last-pair term))))))
+ ((eq? (car term) 'do)
+ (append (list 'do)
+ (list (cadr term))
+ (list (append
+ (list (car (caddr term)))
+ (if (null? (cdr (caddr term)))
+ (list (push-result-var-in var *unspecified*))
+ (append
+ (butlast (cdr (caddr term)) 1)
+ (list
+ (push-result-var-in
+ var
+ (car (my-last-pair (caddr term)))))))))
+ (cdddr term)))
+ ;; ((eq? (car term) 'lambda)
+ ;; (report-error
+ ;; "Compiled function " *current-fun-name* " builds closures."))
+ ((eq? var *return*)
+ (if (eq? (car term) *current-fun-name*)
+ (begin
+ (set! *tailrec-flag* #t)
+ (make-tailrec-call (cdr term)))
+ (list *return* term)))
+ (else
+ (list 'set! var term))))
+
+
+(define (make-tailrec-call args)
+ (define (first-n-reverse n lst)
+ (if (zero? n) '() (cons (car lst) (first-n-reverse (- n 1) (cdr lst)))))
+ (let ((tmp1 '())
+ (tmp2 '())
+ (tmp3 '()))
+ (set! tmp3 (args->list *current-formal-args*))
+ (set! args (make-listarg-arglist *current-formal-args* args))
+ (do ((args-lst args (cdr args-lst))
+ (form-lst tmp3 (cdr form-lst)))
+ ((null? args-lst))
+ (if (not (equal? (car args-lst) (car form-lst)))
+ (begin (set! tmp1 (cons (car args-lst) tmp1))
+ (set! tmp2 (cons (car form-lst) tmp2)))))
+ (set! tmp1 (reverse tmp1))
+ (set! tmp2 (reverse tmp2))
+ (cond
+ ((null? tmp1) (list *goto-tailrec*))
+ ((null? (cdr tmp1))
+ (list 'begin
+ (list 'set! (car tmp2) (car tmp1))
+ (list *goto-tailrec*)))
+ (else
+ (let ((tmplist
+ (first-n-reverse (length tmp1) *tmp-vars*)))
+ (append
+ (list 'let*)
+ (list (map (lambda (x y) (list x y)) tmplist tmp1))
+ (map (lambda (x y) (list 'set! x y)) tmp2 tmplist)
+ (list (list *goto-tailrec*))))))))
+
+
+(define (make-listarg-arglist formals args)
+ (cond ((list? formals) args)
+ ((symbol? formals) (list (normalize-list-aux args)))
+ ((null? args)
+ (report-error
+ "In " *current-fun-name*
+ " a list-taking function is called with too few args."))
+ (else
+ (cons (car args)
+ (make-listarg-arglist (cdr formals) (cdr args))))))
+
+
+(define (build-wrappers funs)
+ (define (build-wrapper-aux arity arg)
+ (cond ((null? arity)
+ '())
+ ((not (pair? arity))
+ (list arg))
+ (else
+ (cons (list 'car arg)
+ (build-wrapper-aux (cdr arity) (list 'cdr arg))))))
+ (define (build-wrapper fun)
+ (let* ((name (cadr fun))
+ (export (assq name *export-table*))
+ (arity (cadr (caddr fun)))
+ (arity2 (assq name *dot-arg-templates*)))
+ (if arity2
+ (set! arity (cadr arity2)))
+ (if (or (not (memq name *export-functions*))
+ (symbol? arity)
+ (and (list? arity)
+ (< (length arity) 4)))
+ #f
+ `(define ,(string->symbol
+ (string-append (symbol->string name)
+ *wrapper-postfix*))
+ (lambda (x)
+ (,*return*
+ (,(if export (cadr export) name)
+ ,@(build-wrapper-aux arity 'x))))))))
+ (let ((res '()))
+ (for-each (lambda (x)
+ (let ((new (build-wrapper x)))
+ (if new
+ (begin
+ (set! res (cons new res))
+ (set! *wrapper-table*
+ (cons (list (cadr x) (cadr new))
+ *wrapper-table*))))))
+ funs)
+ res))
+
+(define (build-wrapped-interpreter-table)
+ (let ((new '())
+ (tmp '()))
+ (do ((part *interpreter-funname-table* (cdr part)))
+ ((null? part)
+ (set! *interpreter-funname-table* new))
+ (set! tmp (assq (caar part) *wrapper-table*))
+ (if tmp
+ (set! new (cons (cons (cadr tmp) (cdar part)) new))
+ (begin
+ (set! tmp (assq (caar part) *export-table*))
+ (if tmp
+ (set! new (cons (cons (cadr tmp) (cdar part)) new))
+ (set! new (cons (car part) new))))))))
+
+
+
+;===================================================================
+;
+; vars-simplifying and lambda-lifting
+;
+;==================================================================
+
+(define *new-vars-nr-for-topfun* 0)
+
+(define (vars-simplify-wholedef def)
+ (let ()
+;;;(pretty-print def)
+ (set! def (compile-quasiquote def))
+;;;(pretty-print def)
+ (set! def (normalize-defines def))
+ (set! *current-fun-name* (cadr def))
+ (set! *top-level-funs* (cons *current-fun-name* *top-level-funs*))
+;;;(pretty-print def)
+ (set! def (if *full-inlining-flag*
+ (subst-inline-full def)
+ (subst-inline def)))
+ (set! def (normalize-delay def))
+;;;(pretty-print def)
+ (set! def (rename-vars def))
+ (set! *new-vars-nr-for-topfun* 0)
+ (set! def (normalize def #f 1))
+;;;(pretty-print def)
+ (set! def (normalize-def-letrecs def))
+ (set! def (beautify-lets def))
+;;;(pretty-print def)
+ def))
+
+
+;;; flatten-wholedef performs the first normalizing and lambda-lifting pass
+
+(define (flatten-wholedef def)
+ (let ()
+;;;(newline)
+;;;(display "starting to flatten def: ") (newline)
+;;;(pretty-print def)
+ (set! *current-fun-name* (cadr def))
+ (set! def (lettify-lambdas def 100 #t))
+;;;(pretty-print def)
+ (set! def (remove-lambdasurrounding-let def))
+;;;(pretty-print def)
+ (set! *new-funs-list* '())
+ (set! def (lambda-lift def '() '()))
+;;;(pretty-print def)
+ (set! *new-funs-list* (cons def *new-funs-list*))
+ *new-funs-list*))
+
+
+(define (lambda-lift term boundvars new-names-args)
+ (let ((tmp '()))
+ (cond
+ ((symbol? term)
+ (set! tmp (assq term new-names-args))
+ (if tmp
+ (cons (cadr tmp) (make-arglist (caddr tmp) '()))
+ term))
+ ((not (pair? term)) term)
+ ((eq? (car term) 'quote) term)
+ ((eq? (car term) 'lambda)
+ (set! tmp (union (args->list (cadr term)) boundvars))
+ (cons 'lambda
+ (cons (cadr term)
+ (map (lambda (x)
+ (lambda-lift x tmp new-names-args))
+ (cddr term)))))
+ ((memq (car term) '(let let* letrec))
+ (lift-let term boundvars new-names-args))
+ ((eq? (car term) 'do)
+ ;; check next line!!!
+ (set! tmp (union (map car (cadr term)) boundvars))
+ (cons 'do
+ (cons (map (lambda (x)
+ (if (null? (cddr x))
+ (list (car x)
+ (lambda-lift (cadr x) boundvars
+ new-names-args))
+ (list (car x)
+ (lambda-lift (cadr x) boundvars
+ new-names-args)
+ (lambda-lift (caddr x)
+ tmp
+ new-names-args))))
+ (cadr term))
+ (map (lambda (x)
+ (lambda-lift x tmp new-names-args))
+ (cddr term)))))
+ ((symbol? (car term))
+ (set! tmp (assq (car term) new-names-args))
+ (let ((args (map (lambda (x)
+ (lambda-lift x boundvars new-names-args))
+ (cdr term))))
+ (if tmp
+ (cons (cadr tmp)
+ (make-arglist (caddr tmp) args))
+ (cons (car term) args))))
+ (else
+ (cons (lambda-lift (car term) boundvars new-names-args)
+ (map (lambda (x)
+ (lambda-lift x boundvars new-names-args))
+ (cdr term)))))))
+
+
+
+(define (lift-let letterm boundvars new-names-args)
+ (let* ((bindings (cadr letterm))
+ (newvars (map car bindings))
+ (body (cddr letterm))
+ (fun-bindings
+ (filter (lambda (x)
+ (and (pair? (cadr x))
+ (eq? (caadr x) 'lambda)))
+ bindings))
+ (other-bindings
+ (filter (lambda (x)
+ (not (memq x fun-bindings)))
+ bindings))
+ (next-bound (union (map car other-bindings) boundvars)))
+
+ (cond ((null? fun-bindings))
+ ((memq (car letterm) '(let* let))
+ (set! new-names-args
+ (make-new-funs-let
+ fun-bindings next-bound new-names-args #f)))
+ ((eq? (car letterm) 'letrec)
+ (set! new-names-args
+ (make-new-funs-letrec
+ fun-bindings next-bound new-names-args #f)))
+ (else (report-error "lift-let applied to non-let term " letterm)))
+
+ (cond ((not (null? other-bindings))
+ (cons (car letterm)
+ (cons (map (lambda (x)
+ (list (car x)
+ (lambda-lift (cadr x)
+ next-bound
+ new-names-args)))
+ other-bindings)
+ (map (lambda (x)
+ (lambda-lift x next-bound new-names-args))
+ body))))
+ ((null? (cdr body))
+ (lambda-lift (car body) next-bound new-names-args))
+ (else
+ (lambda-lift (cons 'begin body) next-bound new-names-args)))))
+
+
+(define (fetchify vars term)
+ (if (null? vars) term (fetchify-aux vars term)))
+
+(define (fetchify-aux vars term)
+ (cond ((symbol? term)
+ (if (memq term vars)
+ (list *c-fetch* term)
+ term))
+ ((not (pair? term))
+ term)
+ ((eq? 'quote (car term))
+ term)
+ ((and (eq? *c-adr* (car term))
+ (memq (cadr term) vars))
+ (cadr term))
+ (else
+ (cons (fetchify-aux vars (car term))
+ (fetchify-aux vars (cdr term))))))
+
+
+(define (make-arglist new-args args)
+ (if (null? (cadr new-args))
+ (append (car new-args) args)
+ (append (map (lambda (x) (list *c-adr* x)) (cadr new-args))
+ (car new-args)
+ args)))
+
+
+(define (normalize-def-letrecs def)
+ (let ((tmp '()))
+ (set! *current-fun-name* (cadr def))
+ (set! tmp
+ (normalize-def-letrecs-aux (caddr def)))
+ (list* (car def) (cadr def) (list tmp))))
+
+(define (normalize-def-letrecs-aux term)
+ (cond ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((eq? 'lambda (car term))
+ (list* (car term) (cadr term)
+ (map normalize-def-letrecs-aux (cddr term))))
+ ((eq? 'letrec (car term))
+ (if (null? (cadr term))
+ (list* 'let* '() (map normalize-def-letrecs-aux (cddr term)))
+ (restructure-letrec (map normalize-def-letrecs-aux term))))
+ (else
+ (map normalize-def-letrecs-aux term))))
+
+(define (restructure-letrec letterm)
+ (let* ((vars (map car (cadr letterm)))
+ (dependencies
+ (map (lambda (x)
+ (list (car x)
+ (occurrences-of vars (cadr x))))
+ (cadr letterm)))
+ (groups (build-sconnected-groups dependencies vars '())))
+ (set! groups (topo-sort dependencies groups))
+ (build-letrec-struct letterm dependencies groups)))
+
+
+(define (build-letrec-struct letterm deps groups)
+ (if (null? groups)
+ (list (cddr letterm))
+ (let ((bind (filter (lambda (x) (memq (car x) (car groups)))
+ (cadr letterm)))
+ (body (build-letrec-struct letterm deps (cdr groups))))
+ (cond
+ ((and (null? (cdar groups))
+ (not (memq (caar groups) (cadr (assq (caar groups) deps)))))
+ (cons 'let
+ (if (symbol? (car body))
+ (list bind body)
+ (cons bind (car body)))))
+ (else
+ (cons 'letrec
+ (if (symbol? (car body))
+ (list bind body)
+ (cons bind (car body)))))))))
+
+;;; lettify-lambdas has a topflag parameter, which is true iff
+;;; the term is a third arg of a toplevel def
+
+(define (lettify-lambdas term var-nr topflag)
+ (cond ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((memq (car term) '(define lambda))
+ (if (not (list? (cddr term)))
+ (report-error
+ *current-fun-name* " has incorrect syntax."))
+ (cons (car term)
+ (cons (cadr term)
+ (map (lambda (x) (lettify-lambdas x var-nr topflag))
+ (cddr term)))))
+ ((and (pair? term)
+ (not (list? term)))
+ (report-error
+ *current-fun-name* " has incorrect syntax."))
+ ((memq (car term) '(let let* letrec))
+ (if (not topflag)
+ (cons (car term)
+ (list* (map (lambda (x)
+ (list (car x)
+ (lettify-lambdas
+ (cadr x) var-nr #f)))
+ (cadr term))
+ (lettify-lambdas (cddr term) var-nr #f)))
+ (cons (car term)
+ (list* (map (lambda (x)
+ (list (car x)
+ (lettify-lambdas
+ (cadr x) var-nr #f)))
+ (cadr term))
+ (map
+ (lambda (x) (lettify-lambdas x var-nr #f))
+ (cddr term))))))
+
+ ((and (memq (car term) '(cond))
+ (find-if (lambda (cl)
+ (find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x))))
+ (cdr cl)))
+ (cdr term)))
+ (let* ((lcl
+ (find-if (lambda (cl)
+ (find-if (lambda (x) (and(pair? x) (eq? 'lambda (car x))))
+ (cdr cl)))
+ (cdr term)))
+ (lterm
+ (find-if (lambda (x) (and(pair? x) (eq? 'lambda (car x)))) lcl))
+ (newvar (make-new-funname))
+ (newlcl (replaceq lterm newvar lcl))
+ (newclauses (replaceq lcl newlcl (cdr term))))
+ `(let ((,newvar ,(lettify-lambdas lterm (+ 1 var-nr) #f)))
+ ,(lettify-lambdas
+ (cons 'cond newclauses) (+ 1 var-nr) #f))))
+ ((find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x)))) term)
+
+ (let* ((lterm (find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x))))
+ term))
+ (newvar (make-new-funname))
+ (newterm (replaceq lterm newvar term)))
+ `(let ((,newvar ,(lettify-lambdas lterm (+ 1 var-nr) #f)))
+ ,(lettify-lambdas newterm (+ 1 var-nr) #f))))
+ (else
+ (map (lambda (x) (lettify-lambdas x var-nr #f)) term))))
+
+
+(define (make-new-funname)
+ (set! *new-fun-nr* (+ 1 *new-fun-nr*))
+ (let ((name
+ (string->symbol
+ (string-append (symbol->string *current-fun-name*)
+ *new-letfun-infix*
+ (number->string *new-fun-nr*)))))
+ (set! *new-fun-names* (cons name *new-fun-names*))
+ name))
+
+
+(define (beautify-lets term)
+ (cond ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((eq? (car term) 'lambda)
+ (cons (car term)
+ (cons (cadr term)
+ (map beautify-lets (cddr term)))))
+ ((and (memq (car term) '(let let*))
+ (eq? 3 (length term))
+ (pair? (caddr term))
+ (memq (car (caddr term)) '(let let*)))
+ (beautify-lets
+ (list* 'let*
+ (map beautify-lets
+ (append (cadr term) (cadr (caddr term))))
+ (cddr (caddr term)))))
+ (else (map beautify-lets term))))
+
+
+;--------------------------------------------------------------
+;
+; topological sorting by dependencies
+;
+;--------------------------------------------------------------
+
+(define (topo-sort deps groups)
+ (let ((res (cons '() '())))
+ (do ((part groups (cdr part)))
+ ((null? part) (cdr res))
+ (topo-insert (car part) res deps))))
+
+(define (topo-insert el lst deps)
+ (let ((found-flag #f))
+ (do ((last-part lst (cdr last-part)))
+ ((or found-flag (null? (cdr last-part)))
+ (if (not found-flag)
+ (set-cdr! last-part (list el)))
+ lst)
+ (if (is-path? (caadr last-part) (car el) deps '())
+ (begin
+ (set-cdr! last-part (cons el (cdr last-part)))
+ (set! found-flag #t))))))
+
+(define (build-sconnected-groups deps input groups)
+ (let ((tmp '()))
+ (cond
+ ((null? input) groups)
+ ((begin (set! tmp
+ (find-if
+ (lambda (grp)
+ (and (not (null? (cdr grp)))
+ (is-path? (car input) (car grp) deps '())
+ (is-path? (car grp) (car input) deps '())))
+ groups))
+ tmp)
+ (build-sconnected-groups deps (cdr input)
+ (cons (cons (car input) tmp) (remove tmp groups))))
+ ((begin (set! tmp
+ (find-if
+ (lambda (in)
+ (and (is-path? (car input) in deps '())
+ (is-path? in (car input) deps '())))
+ (cdr input)))
+ tmp)
+ (build-sconnected-groups deps (remove tmp (cdr input))
+ (cons (list (car input) tmp) groups)))
+ (else
+ (build-sconnected-groups deps (cdr input)
+ (cons (list (car input)) groups))))))
+
+
+(define (is-path? a b deps visited)
+ (set! visited (cons a visited))
+ (set! a (cadr (assq a deps)))
+ (or (memq b a)
+ (find-if (lambda (x)
+ (and (not (memq x visited))
+ (is-path? x b deps visited)))
+ a)))
+
+(define (occurrences-of vars term)
+ (cond ((symbol? term)
+ (if (memq term vars)
+ (list term)
+ '()))
+ ((not (pair? term)) '())
+ ((eq? (car term) 'quote) '())
+ (else
+ (union (occurrences-of vars (car term))
+ (occurrences-of vars (cdr term))))))
+
+
+;---------------------------------------------------------------------
+;
+; build auxiliary functions
+;
+;--------------------------------------------------------------------
+
+
+(define (make-new-funs-let fun-bindings boundvars new-names-args lazy-flag)
+ (for-each
+ (lambda (b)
+ (let* ((freevars (merge-free-vars
+ (introduced-free-vars (cadr b) new-names-args)
+ (free-vars (cadr b) boundvars '())))
+ (new-name (make-new-funname))
+ (tmp (list 'define
+ new-name
+ (cons (caadr b)
+ (cons (make-arglist freevars (cadadr b))
+ (map (lambda (y)
+ (fetchify
+ (cadr freevars)
+ (lambda-lift
+ y
+ (union (args->list (cadadr b))
+ boundvars)
+ new-names-args)))
+ (cddadr b)))))))
+ (set! *new-funs-list* (cons tmp *new-funs-list*))
+ (set! new-names-args
+ (cons (list (car b) new-name freevars)
+ new-names-args))))
+ fun-bindings)
+ new-names-args)
+
+(define (make-new-funs-letrec fun-bindings boundvars new-names-args lazy-flag)
+ (let* ((fun-bodies (cons 'begin (map cadr fun-bindings)))
+ (intro-vars (introduced-free-vars fun-bodies new-names-args))
+ (freevars (merge-free-vars intro-vars
+ (free-vars fun-bodies boundvars '())))
+ (new-names-args
+ (append
+ (map (lambda (b)
+ (list (car b) (make-new-funname) freevars))
+ fun-bindings)
+ new-names-args)))
+ (for-each
+ (lambda (b)
+ (set! *new-funs-list*
+ (cons
+ (list 'define
+ (cadr (assq (car b) new-names-args))
+ (cons (caadr b)
+ (cons (make-arglist freevars (cadadr b))
+ (map (lambda (y)
+ (fetchify (cadr freevars)
+ (lambda-lift y
+ (union
+ (args->list (cadadr b))
+ boundvars)
+ new-names-args)))
+ (cddadr b)))))
+ *new-funs-list*)))
+ fun-bindings)
+ new-names-args))
+
+
+(define (introduced-free-vars term names-args)
+ (if (null? names-args)
+ (list '() '())
+ (introduced-free-vars-aux term names-args)))
+
+(define (introduced-free-vars-aux term names-args)
+ (cond ((symbol? term)
+ (let ((tmp (assq term names-args)))
+ (if tmp (caddr tmp) '(() ()))))
+ ((not (pair? term)) '(() ()))
+ ((eq? 'quote (car term)) '(() ()))
+ (else
+ (merge-free-vars
+ (introduced-free-vars-aux (car term) names-args)
+ (introduced-free-vars-aux (cdr term) names-args)))))
+
+
+(define (new-fun-name a)
+ (if (memq a *new-fun-names*)
+ a
+ (string->symbol
+ (string-append (symbol->string a)
+ *new-fun-infix*
+ (begin (set! *new-fun-nr* (+ 1 *new-fun-nr*))
+ (number->string *new-fun-nr*))))))
+
+
+;-------------------------------------------------------------------
+;
+; free-vars collectors
+;
+;------------------------------------------------------------------
+
+
+;;; all-free-vars takes a term and returns a list (a set) of all
+;;; all free variables in term.
+
+(define (all-free-vars term)
+ (set! *free-vars-list* '())
+ (all-free-aux! term '())
+ *free-vars-list*)
+
+(define (all-free-aux! term bound)
+ (cond
+ ((symbol? term)
+ (if (and (not (memq term bound))
+ (not (memq term *free-vars-list*)))
+ (set! *free-vars-list* (cons term *free-vars-list*))))
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? 'lambda (car term))
+ (let ((new (union (args->list (cadr term)) bound)))
+ (for-each (lambda (x) (all-free-aux! x new)) (cddr term))))
+ ((eq? 'let (car term))
+ (let ((new (union (map car (cadr term)) bound)))
+ (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
+ (for-each (lambda (x) (all-free-aux! x new)) (cddr term))))
+ ((eq? 'let* (car term))
+ (for-each (lambda (x)
+ (all-free-aux! (cadr x) bound)
+ (if (not (memq (car x) bound))
+ (set! bound (cons (car x) bound))))
+ (cadr term))
+ (for-each (lambda (x) (all-free-aux! x bound)) (cddr term)))
+ ((eq? 'letrec (car term))
+ (set! bound (union (map car (cadr term)) bound))
+ (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
+ (for-each (lambda (x) (all-free-aux! x bound)) (cddr term)))
+ ((eq? 'do (car term))
+ (let ((new (union (map car (cadr term)) bound)))
+ (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
+ (for-each (lambda (x)
+ (if (not (null? (cddr x)))
+ (all-free-aux! (caddr x) new)))
+ (cadr term))
+ (for-each (lambda (x) (all-free-aux! x new)) (caddr term))
+ (for-each (lambda (x) (all-free-aux! x new)) (cdddr term))))
+ (else
+ (for-each (lambda (x) (all-free-aux! x bound)) term))))
+
+
+;;; free-vars takes a term, a list of candidates for free vars (vars bound
+;;; somewhere higher in the term) and a list of bound variables.
+;;; The list of candidates is used in order not to consider the global
+;;; variables (external function definitions, *vars*, etc) to be free.
+;;; It returns a list of two disjoint sets: (<ordinary-free> <set!-free>),
+;;; where <set!-free> is a list of free variables which have a set!
+;;; applied to them somewhere in the term.
+;;; The differentiation is important, as ordinary (non-set!)
+;;; free variables are passed as ordinary additional variables
+;;; during lambda-lifting, whereas set!-variables have to be passed
+;;; by reference and treated accordingly (fortunately this is simple
+;;; in C: instead of x always write (*x)).
+
+
+(define (free-vars term checkvars boundvars)
+ (cond ((and (symbol? term) (memq term checkvars))
+ (if (memq term boundvars)
+ '(() ())
+ (list (list term) '())))
+ ((not (pair? term)) '(() ()))
+ ((eq? (car term) 'quote) '(() ()))
+ ((eq? (car term) 'set!)
+ (if (or (memq (cadr term) boundvars)
+ (not (memq (cadr term) checkvars)))
+ (free-vars (caddr term) checkvars boundvars)
+ (merge-free-vars (list '() (list (cadr term)))
+ (free-vars (caddr term) checkvars boundvars))))
+ ((eq? (car term) 'lambda)
+ (free-vars (cddr term)
+ checkvars
+ (append (args->list (cadr term))
+ boundvars )))
+ ((memq (car term) '(let let* letrec))
+ (free-vars (append (map cadr (cadr term))
+ (cddr term))
+ checkvars
+ (append (map car (cadr term))
+ boundvars )))
+ ((eq? (car term) 'do)
+ (free-vars (append (map cadr (cadr term))
+ (map (lambda (x)
+ (if (null? (cddr x)) 1 (caddr x)))
+ (cadr term))
+ (cddr term))
+ checkvars
+ (append (map car (cadr term))
+ boundvars )))
+ (else
+ (merge-free-vars (free-vars (car term) checkvars boundvars)
+ (free-vars (cdr term) checkvars boundvars)))))
+
+(define (merge-free-vars pair-a pair-b)
+ (let* ((norm-a (car pair-a))
+ (norm-b (car pair-b))
+ (set-a (cadr pair-a))
+ (set-b (cadr pair-b))
+ (set-res (union set-a set-b)))
+ (list (set-difference (union norm-a norm-b) set-res)
+ set-res )))
+
+(define *var-nr* 0)
+
+;================================================================
+;
+; substituting in inlined-functions and
+; converting one-arg map-s to map1-s
+;
+;================================================================
+
+
+(define (subst-inline-full term)
+ (let ((new (subst-inline term)))
+ (if (equal? term new)
+ term
+ (subst-inline-full new))))
+
+
+(define (subst-inline term)
+ (cond ((symbol? term)
+ (let ((tmp (assq term *inline-vars-data*)))
+ (if tmp (cadr tmp) term)))
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term))
+ term)
+ ((and (eq? (car term) 'map)
+ (= 3 (length term))
+ (not *always-map->do-flag*)
+ (guaranteed-all-liftable? (list (car term) (cadr term))))
+ (set! *map1-needed-flag* #t)
+ (if (or (pair? (cadr term))
+ (top-nonlist-in-file-defined? (cadr term)))
+ (subst-inline (cons *map1-function* (cdr term)))
+ (subst-inline
+ (list *map1-function*
+ `(lambda (x) (,(cadr term) x))
+ (caddr term)))))
+ ((and (eq? (car term) 'for-each)
+ (= 3 (length term))
+ (not *always-for-each->do-flag*)
+ (guaranteed-all-liftable? (list (car term) (cadr term))))
+ (set! *for-each1-needed-flag* #t)
+ (if (or (pair? (cadr term))
+ (top-nonlist-in-file-defined? (cadr term)))
+ (subst-inline (cons *for-each1-function* (cdr term)))
+ (subst-inline
+ (list *for-each1-function*
+ `(lambda (x) (,(cadr term) x))
+ (caddr term)))))
+ ((memq (car term) *inline-funs*)
+ (let ((data (assq (car term) *inline-funs-data*))
+ (tmp (subst-inline (cdr term))))
+ (subst-inline-aux
+ (caddr (cadr data))
+ (map (lambda (par arg)
+ (list par arg))
+ (cadr (cadr data))
+ tmp))))
+ ((and (eq? (car term) 'set!)
+ (assq (cadr term) *inline-vars-data*))
+ (cons 'set! (cons (cadr term) (map subst-inline (cddr term)))))
+ ((list? term)
+ (map subst-inline term))
+ (else
+ term)))
+
+
+(define (subst-inline-aux term pairs)
+ (cond ((symbol? term)
+ (let ((tmp (assq term pairs)))
+ (if tmp
+ (cadr tmp)
+ term)))
+ ((not (pair? term))
+ term)
+ (else
+ (cons (subst-inline-aux (car term) pairs)
+ (subst-inline-aux (cdr term) pairs)))))
+
+;================================================================
+;
+; normalization (simplifying transformation)
+;
+;================================================================
+
+;;; normalize is a main normalizing function, which should
+;;; normalize a term in one pass.
+;;;
+;;; MB! Quasiquote-compiler, normalize-defines and rename-vars
+;;; must have been applied before the application of the current
+;;; transformer.
+
+(define (normalize term bool-flag var-nr)
+ (cond ((not (pair? term)) term)
+ ((eq? (car term) 'quote) term)
+ ((memq (car term) '(set! set-car! set-cdr! vector-set!))
+ (list 'begin
+ (map (lambda (x) (normalize x bool-flag var-nr)) term)
+ *unspecified*))
+ ((eq? (car term) 'if)
+ (normalize-if (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'cond)
+ (normalize-cond (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'not)
+ (normalize-not (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'and)
+ (normalize-and (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'or)
+ (normalize-or (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'case)
+ (normalize-case term bool-flag var-nr))
+ ((eq? (car term) 'do)
+ (normalize-do (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'lambda)
+ (cons (car term)
+ (cons (cadr term)
+ (normalize (cddr term) bool-flag var-nr))))
+ ((eq? 'letrec (car term))
+ ;;(restructure-letrec
+ ;; (map (lambda (x) (normalize x bool-flag var-nr)) term))
+ (map (lambda (x) (normalize x bool-flag var-nr)) term))
+ ((modified-fun? (car term))
+ (map (lambda (x) (normalize x bool-flag var-nr)) term))
+
+ ((eq? (car term) 'list)
+ (normalize-list term bool-flag var-nr))
+ ((eq? (car term) 'for-each)
+ (for-each->do term bool-flag var-nr))
+ ((eq? (car term) 'map)
+ (map->do term bool-flag var-nr))
+ ((eq? (car term) 'open-input-file)
+ (normalize-open-input-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'open-output-file)
+ (normalize-open-output-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'call-with-input-file)
+ (normalize-call-with-input-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'call-with-output-file)
+ (normalize-call-with-output-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'with-input-from-file)
+ (normalize-with-input-from-file (cdr term) bool-flag var-nr))
+ ((eq? (car term) 'with-output-to-file)
+ (normalize-with-output-to-file (cdr term) bool-flag var-nr))
+ ((eq? 'string-append (car term))
+ (normalize-string-append term bool-flag var-nr))
+ ((assq (car term) *associative-fun-table*)
+ (normalize-associative
+ (assq (car term) *associative-fun-table*)
+ (cdr term) bool-flag var-nr))
+ ((assq (car term) *comparison-fun-table*)
+ (normalize-comparison
+ (assq (car term) *comparison-fun-table*)
+ (cdr term) bool-flag var-nr))
+ (else
+ (map (lambda (x) (normalize x bool-flag var-nr)) term))))
+
+
+;;; for-each->do converts a for-each application to a do cycle.
+;;; The aim is to convert a do cycle into the C for cycle later.
+;;;
+;;; NB! here and in the following transformers bool-flag denotes
+;;; whether the current term occurs as a term of boolean type -
+;;; eg, (if (for-each ....) term1 term2). This allows some
+;;; optimizations (although not directly in for-each, of course).
+;;;
+;;; var-nr is a number of the last generated new variable.
+
+
+(define (for-each->do term bool-flag var-nr)
+ (let* ((fun (cadr term))
+ (args (cddr term))
+ (names (map (lambda (x)
+ (set! var-nr (+ 1 var-nr)) (make-new-var var-nr))
+ args )))
+ `(do
+ ,(map (lambda (x y) (list x y (list 'cdr x)))
+ names
+ (map (lambda (x) (normalize x #f (+ 1 var-nr))) args))
+ ,(list (normalize
+ (if (null? (cdr args))
+ (list 'not (list 'pair? (car names)))
+ (list 'not (cons 'and (map (lambda (x)
+ (list 'pair? x))
+ names))))
+ #t var-nr)
+ *unspecified*)
+ ,(cons (normalize fun #f (+ 1 var-nr))
+ (map (lambda (x) (list 'car x)) names)))))
+
+
+;;; map->do converts a map application to a do cycle.
+
+(define (map->do term bool-flag var-nr)
+ (let* ((fun (cadr term))
+ (args (cddr term))
+ (res (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
+ (res-end (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
+ (tmp (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
+ (names (map (lambda (x)
+ (set! var-nr (+ 1 var-nr)) (make-new-var var-nr))
+ args )))
+ `(do
+ (,@(map (lambda (x y) (list x y (list 'cdr x)))
+ names
+ (map (lambda (x) (normalize x #f (+ 1 var-nr))) args))
+ (,res '())
+ (,res-end '())
+ (,tmp '()))
+ ,(list (normalize
+ (if (null? (cdr args))
+ (list 'not (list 'pair? (car names)))
+ (list 'not (cons 'and (map (lambda (x)
+ (list 'pair? x))
+ names))))
+ #t var-nr)
+ res)
+ (set! ,tmp ,(normalize
+ (cons fun (map (lambda (x) (list 'car x)) names))
+ #f (+ 1 var-nr)))
+ (if (null? ,res)
+ (begin (set! ,res (cons ,tmp '()))
+ (set! ,res-end ,res))
+ (begin (set-cdr! ,res-end (cons ,tmp '()))
+ (set! ,res-end (cdr ,res-end)))))))
+
+
+
+(define (normalize-if term bool-flag var-nr)
+ (if (null? (cddr term))
+ (list 'if
+ (normalize (car term) #t var-nr)
+ (normalize (cadr term) bool-flag var-nr)
+ *unspecified*)
+ (list 'if
+ (normalize (car term) #t var-nr)
+ (normalize (cadr term) bool-flag var-nr)
+ (normalize (caddr term) bool-flag var-nr))))
+
+
+(define (normalize-do term bool-flag var-nr)
+ (if (or (null? (car term))
+ (null? (cdar term)))
+ (list* 'do
+ (map (lambda (x) (normalize x #f var-nr))
+ (car term))
+ (cons (normalize (caadr term) #t var-nr)
+ (map (lambda (x) (normalize x #f var-nr))
+ (cdadr term)))
+ (map (lambda (x) (normalize x #f var-nr))
+ (cddr term)))
+ (begin
+ (let* ((actual (filter (lambda (x) (not (null? (cddr x))))
+ (car term)))
+ (non-actual (filter (lambda (x) (null? (cddr x)))
+ (car term)))
+ (vars (map car actual))
+ (inits (map cadr actual))
+ (bodies (map caddr actual))
+ (new-var '())
+ (new-var-pairs '())
+ (new-bodies '()))
+ (do ((part actual (cdr part))
+ (vars-part vars (cdr vars-part))
+ (bodies-part bodies (cdr bodies-part)))
+ ((null? part))
+ (if (inside-term? (car vars-part) (cdr bodies-part))
+ (begin
+ (set! var-nr (+ 1 var-nr))
+ (set! new-var (make-new-var var-nr))
+ (set! new-var-pairs
+ (cons (list new-var (car vars-part))
+ new-var-pairs))
+ (set! bodies-part
+ (cons (car bodies-part)
+ (subst-term new-var
+ (car vars-part)
+ (cdr bodies-part))))
+ (set! new-bodies
+ (cons (car bodies-part) new-bodies)))
+ (begin
+ (set! new-bodies
+ (cons (car bodies-part) new-bodies)))))
+ (if (null? new-var-pairs)
+ (list* 'do
+ (map (lambda (x) (normalize x #f var-nr))
+ (car term))
+ (cons (normalize (caadr term) #t var-nr)
+ (map (lambda (x) (normalize x #f var-nr))
+ (cdadr term)))
+ (map (lambda (x) (normalize x #f var-nr))
+ (cddr term)))
+ (list 'let*
+ (append
+ non-actual
+ (map (lambda (x) (list (car x) *dummy*)) new-var-pairs))
+ (list* 'do
+ (map (lambda (x y z)
+ (list x (normalize y #f var-nr)
+ (normalize z #f var-nr)))
+ vars
+ inits
+ (reverse new-bodies))
+ (cons (normalize (caadr term) #t var-nr)
+ (map (lambda (x) (normalize x #f var-nr))
+ (cdadr term)))
+ (append (map (lambda (x) (normalize x #f var-nr))
+ (cddr term))
+ (map (lambda (x) (cons 'set! x))
+ new-var-pairs)))))))))
+
+
+
+
+;;; normalize-cond is one of the main transformers.
+;;; It converts a cond to the if-ladder, introducing
+;;; lets and new variables where needed.
+;;;
+;;; NB! In the following *and?* and *or?* are special new functions,
+;;; which are considered to be strictly boolean, and can be
+;;; converted directly to corresponding C operators.
+
+(define (normalize-cond term bool-flag var-nr)
+ (cond
+ ((null? term) *unspecified*)
+ ((null? (cdar term))
+ (if bool-flag
+ `(*and?* ,(normalize (caar term) #t var-nr)
+ ,(normalize-cond (cdr term) #t var-nr))
+ (let ((new-var (make-new-var (+ 1 var-nr))))
+ `(let* ((,new-var ,(normalize (caar term) #f (+ 1 var-nr))))
+ (if ,new-var ,new-var
+ ,(normalize-cond (cdr term) #f var-nr))))))
+ ((eq? (cadar term) '=>)
+ (let ((new-var (make-new-var (+ 1 var-nr))))
+ `(let* ((,new-var ,(normalize (caar term) #f (+ 1 var-nr))))
+ (if ,new-var
+ ,(normalize (list (caddar term) new-var)
+ bool-flag (+ 1 var-nr))
+ ,(normalize-cond (cdr term) bool-flag (+ 1 var-nr))))))
+ ((eq? (caar term) 'else)
+ (if (null? (cddar term))
+ (normalize (cadar term) bool-flag var-nr)
+ (normalize (cons 'begin (cdar term)) bool-flag var-nr)))
+ ((null? (cddar term))
+ `(if ,(normalize (caar term) #t var-nr)
+ ,(normalize (cadar term) bool-flag var-nr)
+ ,(normalize-cond (cdr term) bool-flag var-nr)))
+ (else
+ `(if ,(normalize (caar term) #t var-nr)
+ ,(normalize (cons 'begin (cdar term)) bool-flag var-nr)
+ ,(normalize-cond (cdr term) bool-flag var-nr)))))
+
+
+;;; normalize-not creates a c-not (*not?* => !) or a scheme-not (not)
+
+(define (normalize-not lst bool-flag var-nr)
+ (if bool-flag
+ (normalize (cons *not?* lst) #t var-nr)
+ (list 'not (normalize (car lst) #t var-nr))))
+
+;;; normalize-and and normalize-or make some optimizations
+;;; and convert terms to if-ladders of *and?* and *or?*.
+
+(define (normalize-and lst bool-flag var-nr)
+ (cond ((null? lst) #t)
+ ((null? (cdr lst)) (normalize (car lst) bool-flag var-nr))
+ ((and bool-flag (not *lift-and-or-flag*))
+ (normalize (cons *and?* lst) #t var-nr))
+ (else
+ `(if ,(normalize (car lst) #t var-nr)
+ ,(normalize-and (cdr lst) bool-flag var-nr)
+ #f ))))
+
+
+(define (normalize-or lst bool-flag var-nr)
+ (cond ((null? lst) #f)
+ ((null? (cdr lst)) (normalize (car lst) bool-flag var-nr))
+ ((and bool-flag (not *lift-and-or-flag*))
+ (normalize (cons *or?* lst) #t var-nr))
+ (bool-flag
+ `(if ,(normalize (car lst) #t var-nr)
+ #t
+ ,(normalize-or (cdr lst) #t var-nr)))
+ (else
+ (normalize `(cond ,@(map list (butlast lst 1))
+ (else ,(car (my-last-pair lst))))
+ bool-flag var-nr ))))
+
+
+;;; normalize-case does the obvious thing.
+
+(define (normalize-case term bool-flag var-nr)
+ (let* ((new-var (make-new-var (+ 1 var-nr)))
+ (tmp
+ `(let* ((,new-var ,(cadr term)))
+ (cond
+ ,@(normalize-case-aux new-var (cddr term))))))
+ (normalize tmp bool-flag (+ 1 var-nr))))
+
+
+(define (normalize-case-aux var lst)
+ (cond ((null? lst) '())
+ ((eq? (caar lst) 'else) (list (car lst)))
+ ((list? (caar lst))
+ (append (map (lambda (x) `((eqv? (quote ,x) ,var) ,@(cdar lst)))
+ (caar lst))
+ (normalize-case-aux var (cdr lst))))
+ (else (report-error "Bad case clause syntax:" lst))))
+
+
+
+;;; file-opening and calling with normalization assumes a single
+;;; generic file opening two-arg function *open-file-function* and
+;;; corresponding strings for input and output.
+;;; Calling with files is normalized into a let with assuming
+;;; a function *set-current-input-port-function* and a function
+;;; *set-current-output-port-function*
+
+(define (normalize-open-input-file term bool-flag var-nr)
+ (list *open-file-function*
+ (normalize (car term) #f var-nr)
+ *input-file-modifier*))
+
+(define (normalize-open-output-file term bool-flag var-nr)
+ (list *open-file-function*
+ (normalize (car term) #f var-nr)
+ *output-file-modifier*))
+
+(define (normalize-with-input-from-file term bool-flag var-nr)
+ (let* ((new-var1 (make-new-var (+ 1 var-nr)))
+ (new-var2 (make-new-var (+ 2 var-nr)))
+ (new-var3 (make-new-var (+ 3 var-nr))))
+ `(let* ((,new-var1 (,*open-file-function*
+ ,(normalize (car term) #f new-var3)
+ ,*input-file-modifier*))
+ (,new-var2 (,*set-current-input-port-function* ,new-var1))
+ (,new-var3 (,(normalize (cadr term) bool-flag new-var3))))
+ (close-input-port ,new-var1)
+ (,*set-current-input-port-function* ,new-var2)
+ ,new-var3)))
+
+(define (normalize-with-output-to-file term bool-flag var-nr)
+ (let* ((new-var1 (make-new-var (+ 1 var-nr)))
+ (new-var2 (make-new-var (+ 2 var-nr)))
+ (new-var3 (make-new-var (+ 3 var-nr))))
+ `(let* ((,new-var1 (,*open-file-function*
+ ,(normalize (car term) #f new-var3)
+ ,*output-file-modifier*))
+ (,new-var2 (,*set-current-output-port-function* ,new-var1))
+ (,new-var3 (,(normalize (cadr term) bool-flag new-var3))))
+ (,*set-current-output-port-function* ,new-var2)
+ (close-output-port ,new-var1)
+ ,new-var3)))
+
+(define (normalize-call-with-input-file term bool-flag var-nr)
+ (let* ((new-var1 (make-new-var (+ 1 var-nr)))
+ (new-var2 (make-new-var (+ 2 var-nr))))
+ `(let* ((,new-var1 (,*open-file-function*
+ ,(normalize (car term) #f new-var2)
+ ,*input-file-modifier*))
+ (,new-var2 (,(normalize (cadr term) bool-flag new-var2)
+ ,new-var1)))
+ (close-input-port ,new-var1)
+ ,new-var2)))
+
+
+(define (normalize-call-with-output-file term bool-flag var-nr)
+ (let* ((new-var1 (make-new-var (+ 1 var-nr)))
+ (new-var2 (make-new-var (+ 2 var-nr))))
+ `(let* ((,new-var1 (,*open-file-function*
+ ,(normalize (car term) #f new-var2)
+ ,*output-file-modifier*))
+ (,new-var2 (,(normalize (cadr term) bool-flag new-var2)
+ ,new-var1)))
+ (close-output-port ,new-var1)
+ ,new-var2)))
+
+
+;;; The following normalize-comparisons and
+;;; normalize-associative convert associative functions into
+;;; functions of exactly the arity two. List function is replaced
+;;; by a corresponding cons structure.
+
+(define (normalize-list term bool-flag var-nr)
+ (normalize (normalize-list-aux (cdr term)) bool-flag var-nr))
+
+(define (normalize-list-aux lst)
+ (cond ((null? lst) ''())
+ ((null? (cdr lst)) `(cons ,(car lst) '()))
+ (else
+ `(cons ,(car lst)
+ ,(normalize-list-aux (cdr lst))))))
+
+(define (normalize-list-for-c lst)
+ (cond ((null? lst) '())
+ ((null? (cdr lst)) `(cons ,(car lst) ()))
+ (else
+ `(cons ,(car lst)
+ ,(normalize-list-for-c (cdr lst))))))
+
+(define (normalize-comparison data lst bool-flag var-nr)
+ (cond ((null? lst) (report-error "too few args in comparison " (car data)))
+ ((null? (cdr lst))
+ (report-error "too few args in comparison " (car data)))
+ ((null? (cddr lst))
+ (list (car data)
+ (normalize (car lst) #f var-nr)
+ (normalize (cadr lst) #f var-nr)))
+ ;;at least three args left
+ (else (list *and?*
+ (normalize-comparison data (butlast lst 1)
+ #t var-nr)
+ (let* ((rev (reverse lst))
+ (tmp (list
+ (normalize (cadr rev) #t var-nr)
+ (normalize (car rev) #t var-nr))))
+ (cons (car data) tmp))))))
+
+
+(define (normalize-string-append term bool-flag var-nr)
+ (list (car term)
+ (normalize (normalize-list-aux (cdr term)) #f var-nr)))
+
+
+(define (normalize-associative data lst bool-flag var-nr)
+ (cond ((null? lst) (cadr data))
+ ((null? (cdr lst))
+ (list (car data)
+ (cadr data)
+ (normalize (car lst) (boolean? (cadr data)) var-nr)))
+ ((null? (cddr lst))
+ (list (car data)
+ (normalize (car lst) (boolean? (cadr data)) var-nr)
+ (normalize (cadr lst) (boolean? (cadr data)) var-nr)))
+ ;;at least three args left
+ ((boolean? (cadr data)) ; *or?* and *and?*
+ (list (car data)
+ (normalize (car lst) #t var-nr)
+ (normalize-associative data (cdr lst) #t var-nr)))
+ (else
+ (list (car data)
+ (normalize-associative data (butlast lst 1) #f var-nr)
+ (normalize (car (my-last-pair lst)) #f var-nr)))))
+
+
+(define *associative-fun-table*
+ (append
+ (list (cons *or?* '(#f bool)) (cons *and?* '(#t bool)))
+
+ '((append '() lst) ;;; (string-append "" str)
+ (+ 0 num) (- 0 num) (* 1 num) (/ 1 num) (max -99999 num) (min 99999 num)
+ (%+ 0 num) (%- 0 num) (%* 1 num) (%/ 1 num))))
+
+(define *comparison-fun-table*
+ '((= num) (< num) (> num) (<= num) (>= num)
+ (%= num) (%< num) (%> num) (%<= num) (%>= num)
+ (char=? chr) (char<? chr) (char>? chr) (char<=? chr) (char>=? chr)
+ (char-ci=? chr) (char-ci<? chr) (char-ci>? chr)
+ (char-ci<=? chr) (char-ci>=? chr)
+ (string=? str) (string<? str) (string>? str) (string<=? str) (string>=? str)
+ (string-ci=? str) (string-ci<? str) (string-ci>? str)
+ (string-ci<=? str) (string-ci>=? str)))
+
+; pre-4d-version:
+;(define (make-new-var nr)
+; (string->symbol (string-append *new-var-name* (number->string nr))))
+
+; from-4d-version:
+(define (make-new-var nr)
+ (set! *new-vars-nr-for-topfun* (+ 1 *new-vars-nr-for-topfun*))
+ (string->symbol (string-append *new-var-name*
+ (number->string *new-vars-nr-for-topfun*))))
+
+;==================================================================
+;
+; delay transformer
+;
+;=================================================================
+
+
+;;; The following normalizes applications of 'delay'.
+;;; It should be used as a preprocessor to normalizer.
+
+(define (normalize-delay term)
+ (cond ((not (pair? term)) term)
+ ((not (some-in-fun-position? '(delay force) term))
+ term)
+ ((eq? (car term) 'quote) term)
+ ((eq? (car term) 'lambda)
+ `(lambda ,(cadr term) ,@(normalize-delay (cddr term))))
+ ((eq? (car term) 'define)
+ (cons 'define
+ (cons (cadr term)
+ (normalize-delay (cddr term)))))
+ ((and (eq? (car term) 'delay)
+ (pair? (cdr term))
+ (null? (cddr term)))
+ `(,*make-promise-function*
+ (lambda () ,(normalize-delay (cadr term)))))
+ ((and (eq? (car term) 'force)
+ (pair? (cdr term))
+ (null? (cddr term)))
+ `(,*force-function* ,(normalize-delay (cadr term))))
+ (else
+ (map normalize-delay term))))
+
+
+;==================================================================
+;
+; quasiquote transformer
+;
+;=================================================================
+
+
+;;; The following compiles quasiquotes. It should be used as a
+;;; preprocessor to normalizer. It should compile the full
+;;; quasiquote syntax, including nested quasiquotes.
+
+(define (compile-quasiquote term)
+ (cond ((not (pair? term)) term)
+ ((not (occurs-in-function-position? 'quasiquote term)) term)
+ ((eq? (car term) 'quote) term)
+ ((eq? (car term) 'lambda)
+ `(lambda ,(cadr term) ,@(compile-quasiquote (cddr term))))
+ ((eq? (car term) 'define)
+ (cons 'define
+ (cons (cadr term)
+ (compile-quasiquote (cddr term)))))
+ ((eq? (car term) 'quasiquote)
+ (normalize-quasiquote (cadr term) 1))
+ (else
+ (map compile-quasiquote term))))
+
+
+(define (normalize-quasiquote term depth)
+ (cond
+;;; ((not (or (occurs-in-function-position? 'unquote term)
+;;; (occurs-in-function-position? 'unquote-splicing term)))
+;;; `(quote ,term))
+ ((vector? term)
+ `(apply vector ,(normalize-quasiquote (vector->list term) depth)))
+ ((not (pair? term))
+ `(quote ,term))
+ ((and (eq? (car term) 'unquote) (eqv? depth 1))
+ (car (compile-quasiquote (cdr term))))
+ ((not (pair? (car term)))
+ `(cons (quote ,(car term))
+ ,(normalize-quasiquote (cdr term) depth)))
+ ((eq? (caar term) 'unquote)
+ (if (eqv? depth 1)
+ `(cons ,(compile-quasiquote (cadar term))
+ ,(normalize-quasiquote (cdr term) depth))
+ (list 'cons
+ (list 'cons
+ ''unquote
+ (normalize-quasiquote (cdar term) (- depth 1)))
+ (normalize-quasiquote (cdr term) depth))))
+ ((eq? (caar term) 'unquote-splicing)
+ (if (eqv? depth 1)
+ `(append ,(compile-quasiquote (cadar term))
+ ,(normalize-quasiquote (cdr term) depth))
+ (list 'cons
+ (list 'cons
+ ''unquote-splicing
+ (normalize-quasiquote (cdar term) (- depth 1)))
+ (normalize-quasiquote (cdr term) depth))))
+ ((eq? (caar term) 'quasiquote)
+ `(cons ,(normalize-quasiquote (car term) (+ 1 depth))
+ ,(normalize-quasiquote (cdr term) depth)))
+ (else
+ `(cons ,(normalize-quasiquote (car term) depth)
+ ,(normalize-quasiquote (cdr term) depth)))))
+
+
+
+
+(define (occurs-in-function-position? f term)
+ (and (pair? term)
+ (or (and (eq? (car term) f) (list? (cdr term)))
+ (occurs-in-function-position? f (car term))
+ (occurs-in-function-position? f (cdr term)))))
+
+;=============================================================
+;
+; removing topmost surrounding let's
+;
+;===========================================================
+
+
+(define (remove-lambdasurrounding-let def)
+ (if (and (list? def)
+ (eq? 3 (length def))
+ (pair? (caddr def))
+ (or (eq? 'let (car (caddr def)))
+ (eq? 'let* (car (caddr def))))
+ (pair? (cddr (caddr def)))
+ (pair? (caddr (caddr def)))
+ (null? (cdddr (caddr def)))
+ (eq? 'lambda (car (caddr (caddr def)))))
+ (remove-lambdasurrounding-let-aux def)
+ def))
+
+(define (remove-lambdasurrounding-let-aux def)
+ (let* ((letbindings (cadr (caddr def)))
+ (lambdaterm (caddr (caddr def))))
+ (set! *global-vars-list*
+ (append *global-vars-list* (map car letbindings)))
+ (set! *top-actions-list*
+ (append (map (lambda (x)
+ (let ((name (make-constant-name)))
+ (set! *var-make-list*
+ (cons
+ (list 'set! (car x)
+ (list 'scm-gc-protect
+ (list *c-adr* name)))
+ *var-make-list*))
+ (set! *via-interpreter-defined*
+ (cons (car x) *via-interpreter-defined*))
+ (list 'set! (car x) (cadr x))))
+ letbindings)
+ *top-actions-list*))
+ (list (car def) (cadr def) lambdaterm)))
+
+
+
+
+;=============================================================
+;
+; variable renaming
+;
+;============================================================
+
+
+;;; rename-vars performs a very important function: it renames
+;;; vars, removing clashes of bound variable names.
+;;; rename-vars tries to rename as few variables as possible;
+;;; in doing that it takes into account that all variable declarations
+;;; in the term should be liftable to the very top of the term.
+;;;
+;;; After applying rename-vars, all variable bindings in lets can
+;;; (and should) be changed to simple set!s in the corresponding order.
+;;;
+;;; That is, the resulting let is actually a let*, or, better yet,
+;;; (let ((a b) ... (g h)) ...) should be treated
+;;; as (begin (set! a b) ... (set! g h) ...).
+;;; All the variables introduced in such lets should be declared
+;;; as local variables of a pointer type in the corresponding
+;;; c function, and set! should be translated to = in the
+;;; obvious way. Thus the resulting let can be translated to the
+;;; C block, for example.
+;;;
+;;; NB! Different types of lets (including the one in do) are all
+;;; converted to the scheme explained above.
+;;;
+;;; NB! Letrec is not handled fully here, in the sense that when
+;;; we perform lambda-lifting, there are some special complexities
+;;; which must be handled.
+
+
+(define *passed-locvars-list* '())
+
+(define (rename-vars term)
+ (set! *var-nr* 0)
+ (set! *passed-locvars-list* '())
+ (set! *free-vars-list* (all-free-vars term))
+ (rename-vars-aux term '() #t))
+
+
+;;; rename-vars-aux takes a topflag, which is true iff term is NOT yet
+;;; inside some lambdaterm. In that case all the vars bound in let are
+;;; renamed by a global scheme in order to be initialized in the
+;;; initialization function.
+
+(define (rename-vars-aux term env topflag)
+ (cond
+ ((symbol? term)
+ (cond ((assq term env) => cdr)
+ (else term)))
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((eq? 'lambda (car term))
+ `(lambda
+ ,@(rename-vars-aux (cdr term)
+ (make-new-env-lambda
+ (args->list (cadr term))
+ env)
+ #f)))
+ ((eq? 'let (car term))
+ (let ((new-env (make-new-env (map car (cadr term)) env topflag)))
+ `(let
+ ,(map (lambda (x)
+ (list (rename-vars-aux (car x) new-env topflag)
+ (rename-vars-aux (cadr x) env topflag)))
+ (cadr term))
+ ,@(rename-vars-aux (cddr term) new-env topflag))))
+ ((eq? 'do (car term))
+ (let ((new-env (make-new-env (map car (cadr term)) env #f)))
+ `(do
+ ,(map (lambda (x)
+ (cons (rename-vars-aux (car x) new-env #f)
+ (cons (rename-vars-aux (cadr x) env #f)
+ (rename-vars-aux (cddr x)
+ new-env #f))))
+ (cadr term))
+ ,@(rename-vars-aux (cddr term) new-env #f))))
+ ((eq? 'let* (car term))
+ (let ((new-env env)
+ (old-env env)
+ (new-args '()))
+ (do ((part (cadr term) (cdr part)))
+ ((null? part)
+ `(let
+ ,(reverse new-args)
+ ,@(rename-vars-aux (cddr term) new-env topflag)))
+ (set! old-env new-env)
+ (set! new-env (make-new-env (list (caar part)) new-env topflag))
+ (set! new-args
+ (cons (list (rename-vars-aux (caar part) new-env topflag)
+ (rename-vars-aux
+ (cadar part) old-env topflag))
+ new-args )))))
+ ((eq? 'letrec (car term))
+ (let ((new-env (make-new-env (map car (cadr term)) env topflag)))
+ `(letrec ,@(rename-vars-aux (cdr term) new-env topflag))))
+ ((eq? 'define (car term))
+ (map (lambda (x) (rename-vars-aux x env topflag)) term))
+ ((list? term)
+ (map (lambda (x) (rename-vars-aux x env #f)) term))
+ (else (cons (rename-vars-aux (car term) env #f)
+ (rename-vars-aux (cdr term) env #f)))))
+
+
+(define (args->list args)
+ (cond ((symbol? args) (list args))
+ ((list? args)
+ (map (lambda (x) (if (pair? x) (cadr x) x)) args))
+ ((pair? args)
+ (cons (if (pair? (car args)) (cadar args) (car args))
+ (args->list (cdr args))))
+ (else (report-error "Bad argument list:" args))))
+
+
+(define (make-new-env vars env topflag)
+ (let ((name '()))
+ (append (map (lambda (x)
+ (cond
+ ((or (memq x *new-fun-names*)
+ (and (not (assq x env))
+ (not topflag)
+ (not (memq x *keywords*))
+ (not (memq x *primitives*))
+ (not (memq x *top-level-names*))
+ (not (memq x *passed-locvars-list*))
+ (not (memq x *free-vars-list*))))
+ (set! *passed-locvars-list*
+ (cons x *passed-locvars-list*))
+ (cons x x))
+ ((not topflag)
+ (set! *var-nr* (+ 1 *var-nr*))
+ (cons x
+ (string->symbol
+ (string-append
+ (symbol->string x)
+ *local-var-infix*
+ (number->string *var-nr*)))))
+ (else
+ (set! *new-fun-nr* (+ 1 *new-fun-nr*))
+ (cons x
+ (string->symbol
+ (string-append
+ (symbol->string x)
+ *new-fun-infix*
+ (number->string *new-fun-nr*)))))))
+ vars)
+ env )))
+
+(define (make-new-env-lambda vars env)
+ (append (map (lambda (x)
+ (if (or (assq x env)
+ (memq x *keywords*)
+ (memq x *primitives*)
+ (memq x *top-level-names*))
+ (cons x
+ (string->symbol
+ (string-append
+ (symbol->string x)
+ *local-var-infix*
+ (begin (set! *var-nr* (+ 1 *var-nr*))
+ (number->string *var-nr*)))))
+ (cons x x)))
+ vars )
+ env ))
+
+
+;===============================================================
+;
+; define - transformer
+;
+;===============================================================
+
+;;; normalize-defines converts fancy defines into basic ones.
+
+(define (normalize-defines term)
+ (cond
+ ((not (pair? term)) term)
+ ((eq? (car term) 'quote) term)
+ ((eq? (car term) 'define)
+ ;; the coming if removes let in the case:
+ ;; (define foo (let ((bar bar)) ...))
+ ;; (if (and (pair? (cdr term))
+ ;; (pair? (cddr term))
+ ;; (pair? (caddr term))
+ ;; (memq (car (caddr term)) '(let let* letrec))
+ ;; (pair? (cadr (caddr term)))
+ ;; (not (find-if (lambda (x) (not (eq? (car x) (cadr x))))
+ ;; (cadr (caddr term)))))
+ ;; (set! term (cons 'define (cons (cadr term) (cddr (caddr term))))))
+ (if (pair? (cadr term))
+ `(define ,(caadr term)
+ ,(normalize-defines
+ (cons 'lambda (cons (cdadr term) (cddr term)))))
+ `(define ,(cadr term) ,(normalize-defines (caddr term)))))
+ ((and (memq (car term) '(let* letrec))
+ (not (list? (cadr term))))
+ (report-error
+ "In " *current-fun-name* " there is wrong let: " term))
+
+ ;;; the next case rewrites a named let to a letrec, never succeeds.
+ ((begin
+ (if (and (eq? (car term) 'let)
+ (not (null? (cdr term)))
+ (not (null? (cddr term)))
+ (symbol? (cadr term))
+ (not (null? (cadr term))))
+ ;;; a named let
+ (if (find-if (lambda (x)
+ (or (null? x) (not (list? x)) (null? (cdr x))))
+ (caddr term))
+ (report-error
+ *current-fun-name*
+ " contains an incorrect named let: " term)
+ (let ((param (map car (caddr term)))
+ (args (map cadr (caddr term))))
+ (set! term
+ (list 'letrec
+ (list
+ (list (cadr term)
+ (list* 'lambda param (cdddr term))))
+ (cons (cadr term) args))))))
+ #f))
+ ((and (memq (car term) '(lambda let let* letrec do))
+ (pair? (caddr term))
+ (eq? 'define (caaddr term)))
+ (let ((defs (normalize-defines-aux (cddr term)))
+ (other (member-if
+ (lambda (x)
+ (or (not (pair? x)) (not (eq? (car x) 'define))))
+ (cddr term))))
+ (if (not other) (report-error "Body is missing:" term))
+ `(,(car term)
+ ,(normalize-defines (cadr term))
+ ,(normalize-defines (cons 'letrec (cons defs other))))))
+ ((list? term)
+ (map normalize-defines term))
+ (else
+ (cons (normalize-defines (car term))
+ (normalize-defines (cdr term))))))
+
+
+(define (normalize-defines-aux lst)
+ (if (and (not (null? lst)) (pair? (car lst)) (eq? 'define (caar lst)))
+ (cons (cdr (normalize-defines (car lst)))
+ (normalize-defines-aux (cdr lst)))
+ '()))
+
+;=================================================================
+;
+; Global analysis
+;
+;=================================================================
+
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+;
+; analysis for liftability and mutability
+;
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+; lift-analyse-def! takes a def where all the lambdas are renamed
+; (by taking extra let-s with names), vars are renamed and letrecs
+; are ordered.
+;
+; it dest. changes the def body by replacing the leading lambda of
+; all the liftable lambdaterms with the value of *liftable-lambda*
+
+
+(define *local-liftnames* '())
+(define *liftable-lambda* '**liftable-lambda**)
+(define *def-hofname* '())
+
+(define (lift-analyse-def! def)
+ (let* ((funname (cadr def))
+ (lterm (caddr def)))
+ (set! *local-liftnames* '())
+ (set! *def-hofname* funname)
+ (lift-analyse-def-aux! lterm)
+ (if (and (pair? lterm)
+ (not (all-liftable? (cdr lterm))))
+ (set! *not-all-liftable-names*
+ (cons funname *not-all-liftable-names*)))))
+
+
+; lift-analyse-def-aux! term:
+; term is a term
+;
+; all lambdaterms must be named.
+;
+; liftable lambdas are destr. replaced by *liftable-lambda*,
+; their names are added to *local-liftnames*
+;
+
+(define (lift-analyse-def-aux! term)
+ (let* ((name '())
+ (passed '())
+ (tmp '()))
+ (cond
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? 'lambda (car term))
+ (for-each (lambda (x) (lift-analyse-def-aux! x)) (cddr term)))
+;;; ((eq? *liftable-lambda* (car term))
+;;; (for-each (lambda (x) (lift-analyse-def-aux! x)) (cddr term)))
+ ((and (pair? (car term))
+ (eq? 'lambda (caar term)))
+ (for-each lift-analyse-def-aux! (cddar term))
+ (if (all-liftable? (cddar term))
+ (set-car! (car term) *liftable-lambda*))
+ (for-each lift-analyse-def-aux! (cdr term)))
+ ((memq (car term) '(let* let))
+ (for-each lift-analyse-def-aux! (cddr term))
+ (do ((part (reverse (cadr term)) (cdr part)))
+ ((null? part))
+ (set! name (caar part))
+ (lift-analyse-def-aux! (cadar part))
+ (if (and (pair? (cadar part))
+ (eq? 'lambda (caadar part))
+ (all-liftable? (cddr (cadar part)))
+ (liftable-nameocc? name (cddr (cadar part)))
+ (liftable-nameocc? name (cons 'begin passed))
+ (liftable-nameocc? name (cons 'begin (cddr term))))
+ (begin
+ (set! *local-liftnames*
+ (cons name *local-liftnames*))
+ (set-car! (cadar part) *liftable-lambda*)))
+ (set! passed (cons (cadar part) passed))))
+ ((eq? (car term) 'letrec)
+ (for-each lift-analyse-def-aux! (cddr term))
+ (for-each (lambda (el) (lift-analyse-def-aux! (cadr el))) (cadr term))
+ (if (and (every1 (lambda (el)
+ (and (pair? (cadr el))
+ (eq? 'lambda (caadr el))
+ (all-liftable? (cddr (cadr el)))))
+ (cadr term))
+ (every1 (lambda (el)
+ (and (liftable-nameocc? (car el)
+ (cons 'begin (cddr term)))
+ (every1 (lambda (el2)
+ (liftable-nameocc?
+ (car el) (cddr (cadr el2))))
+ (cadr term))))
+ (cadr term)))
+ (for-each (lambda (el)
+ (set! *local-liftnames*
+ (cons (car el) *local-liftnames*))
+ (set-car! (cadr el) *liftable-lambda*))
+ (cadr term))))
+ ((and (liftable-hofname? (car term))
+ (not (eq? (car term) *def-hofname*)))
+ (set! tmp (assq (car term) *liftable-hof-database*))
+ ;; (if tmp (begin (newline) (display "term: ") (display term) (newline)))
+ (if tmp
+ ;; case for top-level def of a higher-order fun:
+ (if (every1 (lambda (x)
+ ;; (newline) (display "x: ") (display x) (newline)
+ (let ((param (car x))
+ (arg (cdr x)))
+ ;; (display "param: ") (display param) (newline)
+ ;; (display "arg: ") (display arg) (newline)
+ (if param
+ (or (and (pair? arg)
+ (or (eq? 'lambda (car arg))
+ (eq? *liftable-lambda*
+ (car arg)))
+ (begin
+ (for-each
+ lift-analyse-def-aux!(cddr arg))
+ ;; (newline) (display "cddr arg:")
+ ;; (display (cddr arg)) (newline)
+ (all-liftable? (cddr arg))))
+ (and (symbol? arg)
+ (memq arg *top-level-names*)
+ (not (modified-fun? arg))))
+ #t)))
+ (map cons (cdr tmp) (cdr term)))
+ (for-each (lambda (param arg)
+ (if (and param
+ (pair? arg)
+ (eq? 'lambda (car arg))
+ (all-liftable? (cddr arg)))
+ (set-car! arg *liftable-lambda*)))
+ (cdr tmp)
+ (cdr term))
+ (let ((name
+ (string->symbol
+ (string-append (symbol->string (car term))
+ *export-hof-postfix*))))
+ (set! *top-level-names*
+ (cons name *top-level-names*))
+ (set-car! term name)))
+ ;; case for map and for-each:
+ (for-each (lambda (arg)
+ (if (and (pair? arg)
+ (eq? 'lambda (car arg)))
+ (set-car! arg *liftable-lambda*)))
+ (cdr term)))
+ (for-each (lambda (x) (lift-analyse-def-aux! x)) (cdr term)))
+ (else
+ (for-each (lambda (x) (lift-analyse-def-aux! x)) term)))))
+
+
+(define (all-liftable? term)
+ (cond ((not (pair? term)) (not (eq? 'lambda term)))
+ ((eq? 'quote (car term)) #t)
+ (else (and (all-liftable? (car term))
+ (all-liftable? (cdr term))))))
+
+(define (guaranteed-all-liftable? term)
+ (cond ((not (pair? term)) (not (eq? 'lambda term)))
+ ((eq? 'quote (car term)) #t)
+ ((and (or (eq? 'map (car term)) (eq? 'for-each (car term))
+ (eq? *map1-function* (car term))
+ (eq? *for-each1-function* (car term)))
+ (pair? (cdr term))
+ (pair? (cadr term)))
+ (and (guaranteed-all-liftable? (cdadr term))
+ (guaranteed-all-liftable? (cddr term))))
+ (else (and (guaranteed-all-liftable? (car term))
+ (guaranteed-all-liftable? (cdr term))))))
+
+(define (lift-unmark-def! term)
+ (cond
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? *liftable-lambda* (car term))
+ (set-car! term 'lambda)
+ (for-each lift-unmark-def! (cdr term)))
+ ((list? term)
+ (for-each lift-unmark-def! term))
+ (else term)))
+
+
+; liftable-nameocc? name term:
+; name a name of some fun,
+; term is the term where the use of name is checked.
+;
+; gives #f iff name is used in the nonliftable context
+
+(define (liftable-nameocc? name term)
+ (cond
+ ((not (pair? term)) #t)
+ ((eq? 'quote (car term)) #t)
+ ((eq? 'lambda (car term))
+ (not (inside-term? name (cddr term))))
+ ((and (memq name (cdr term))
+ (not (liftable-hofname? (car term))))
+ #f)
+ (else
+ (every1 (lambda (x) (liftable-nameocc? name x)) term))))
+
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+;
+; checking liftability of higher-order funs
+;
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(define *liftable-hof-primitives*
+ (list *map1-function* *for-each1-function* 'map 'for-each))
+
+(define (liftable-hofname? name)
+ (and (or (memq name *liftable-hof-primitives*)
+ (memq name *liftable-hof-names*))
+ (not (modified-fun? name))))
+
+
+; liftable-hof? lterm name:
+; checks whether lterm with name is a liftable hof
+
+
+(define (liftable-hof? lterm name)
+ (let* ((args (args->list (cadr lterm)))
+ (hof-args (filter-hof-args lterm args)))
+ (if (and (not (null? hof-args))
+ (liftable-nameocc? name (cddr lterm))
+ (not (member-if (lambda (x)
+ (not (liftable-hofvars-usage?
+ x name hof-args args)))
+ (cddr lterm))))
+ (begin
+ (set! *liftable-hof-database*
+ (cons (cons name (map (lambda (x) (if (memq x hof-args) #t #f))
+ args))
+ *liftable-hof-database*))
+ #t)
+ (if (not (null? hof-args))
+ (begin (set! *non-liftable-hof-names*
+ (cons name *non-liftable-hof-names*))
+ #f)
+ #f))))
+
+
+; filter-hof-args term args:
+; filters out the functional args from args
+
+
+(define *found-hof-args* '())
+(define *check-hof-args* '())
+
+(define (filter-hof-args term args)
+ (if (null? args)
+ '()
+ (begin
+ (set! *check-hof-args* args)
+ (set! *found-hof-args* '())
+ (filter-hof-args-aux! term)
+ *found-hof-args*)))
+
+
+(define (filter-hof-args-aux! term)
+ (let* ((tmp '()))
+ (cond
+ ((null? *check-hof-args*))
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? 'lambda (car term))
+ (for-each filter-hof-args-aux! (cddr term)))
+ ((begin (set! tmp (memq (car term) *check-hof-args*))
+ tmp)
+ (set! *found-hof-args* (cons (car tmp) *found-hof-args*))
+ (set! *check-hof-args* (remove-one (car tmp) *check-hof-args*))
+ (for-each filter-hof-args-aux! term))
+ (else
+ (for-each filter-hof-args-aux! term)))))
+
+; liftable-hofvars-usage? term name hof-args:
+; checks that hof-args are used in the term with name only
+; in the function position or as same args to name itself and
+; that the name is not called with lambdaterms at hof-places
+; and that hof-places are exactly the same args.
+; hof-args may also not occur in the inside lambda-terms.
+
+(define (liftable-hofvars-usage? term name hof-args args)
+ (cond
+ ((not (pair? term)) #t)
+ ((eq? 'quote (car term)) #t)
+ ((or (eq? 'lambda (car term)) (eq? *liftable-lambda* (car term)))
+ (not (find-if (lambda (x) (some-inside-term? hof-args x)) (cddr term))))
+ ((eq? name (car term))
+ (every1 (lambda (x)
+ (let ((param (car x))
+ (arg (cdr x)))
+ (if (memq param hof-args)
+ (eq? param arg)
+ (and (not (memq arg hof-args))
+ (not (and (pair? arg) (eq? 'lambda (car arg))))))))
+ (map cons args (cdr term))))
+ (else
+ (and (every1 (lambda (el) (not (memq el hof-args))) (cdr term))
+ (every1 (lambda (x) (liftable-hofvars-usage? x name hof-args args))
+ term)))))
+
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+;
+; checking for redefining of functions
+;
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+(define *keywords*
+ '(=> and begin case cond define delay do else if lambda
+ let let letrec or quasiquote quote set! unquote
+ unquote-splicing))
+
+(define (modified-fun? name)
+ (cond
+ (*all-funs-modified-flag*
+ (or (memq name *primitives*)
+ (memq name *top-level-names*)))
+ (*new-funs-modified-flag*
+ (or (memq name *modified-primitives*)
+ (memq name *top-level-names*)))
+ (else
+ (or (memq name *modified-primitives*)
+ (memq name *modified-top-level-names*)))))
+
+(define *top-level-names* '())
+(define *modified-primitives* '())
+(define *modified-top-level-names* '())
+
+(define (make-top-level-namelist! expr-list)
+ (set! *top-level-names* '())
+ (set! *modified-primitives* '())
+ (set! *modified-top-level-names* '())
+ (set! *check-redefining-passed* '())
+ (make-top-level-namelist-aux! expr-list #f)
+;;; (pretty-print expr-list)
+ (make-top-level-namelist-aux! expr-list #t)
+;;; (pretty-print expr-list)
+ (set! *modified-primitives*
+ (set-difference *modified-primitives* *general-transcedentals*))
+ *top-level-names*)
+
+(define *general-transcedentals*
+ '(sqrt log expt exp sin cos tan asin acos atan sinh cosh tanh asinh tanh
+ asinh acosh atanh))
+
+(define (make-top-level-namelist-aux! expr-list redefining-flag)
+ (if (and (pair? expr-list) (list? expr-list))
+ (for-each
+ (lambda (expr)
+ (cond
+ ((not (pair? expr)))
+ ((not (list? expr)))
+ ((eq? 'quote (car expr)))
+ ((eq? (car expr) 'define)
+ (let ((new (normalize-top-define expr)))
+ (if redefining-flag
+ (check-redefining! new #t)
+ (set! *top-level-names*
+ (cons (cadr new) *top-level-names*)))))
+ ((and (eq? 'set! (car expr))
+ redefining-flag)
+ (check-redefining! expr #t))
+ ((not redefining-flag)
+ (for-each (lambda (x) (make-top-level-namelist-aux! x #f))
+ expr))))
+ expr-list)))
+
+(define (compute-floats-flag! term opsflag)
+ (cond (*floats-flag* #t)
+ ((pair? term)
+ (if (eq? 'quote (car term))
+ (compute-floats-flag! (cdr term) #f)
+ (or (compute-floats-flag! (car term) opsflag)
+ (compute-floats-flag! (cdr term) opsflag))))
+ ((vector? term)
+ (do ((i (- (vector-length term) 1) (- i 1)))
+ ((< i 0) *floats-flag*)
+ (compute-floats-flag! (vector-ref term i) opsflag)))
+ ((number? term)
+ (if (or (not (integer? term))
+ (not (exact? term))
+ (> term most-positive-fixnum)
+ (< term most-negative-fixnum))
+ (begin (set! *floats-flag* term) #t)
+ #f))
+ ((not opsflag) #f)
+ ((symbol? term)
+ (if (memq term *float-recognize-ops*)
+ (begin (set! *floats-flag* term) #t)
+ #f))
+ (else #f)))
+
+
+(define *float-recognize-ops*
+ '($sin $cos $tan $asin $acos $atan $sinh $cosh $tanh $asinh $tanh
+ $asinh $acosh $atanh $sqrt $expt $log $abs $exp
+ sin cos tan asin acos atan sinh cosh tanh asinh tanh
+ asinh acosh atanh))
+
+
+(define *check-redefining-passed* '())
+
+(define (check-redefining! term top-level-flag)
+ (let* ((new '()))
+ (cond
+ ((not (pair? term)))
+ ((not (list? term)))
+ ((eq? 'quote (car term)))
+ ((or (eq? 'set! (car term))
+ (and top-level-flag (eq? 'define (car term))))
+ (if (eq? 'define (car term))
+ (set! new (normalize-top-define term))
+ (set! new term))
+ (if (not (eq? 3 (length term)))
+ (report-error " wrong set! or define syntax: " term))
+ (if (memq (cadr new) *keywords*)
+ (report-error " a keyword is set! or defined: " term))
+ (if (memq (cadr new) *primitives*)
+ (or (memq (cadr new) *modified-primitives*)
+ (set! *modified-primitives*
+ (cons (cadr term) *modified-primitives*))))
+ (if (and (memq (cadr new) *top-level-names*)
+ (not (memq (cadr new) *hobbit-declaration-vars*)))
+ (or (memq (cadr new) *modified-top-level-names*)
+ (if (and (eq? 'define (car new))
+ (not (memq (cadr new) *check-redefining-passed*)))
+ (set! *check-redefining-passed*
+ (cons (cadr new) *check-redefining-passed*))
+ (set! *modified-top-level-names*
+ (cons (cadr new) *modified-top-level-names*)))))
+ (check-redefining! (caddr new) #f))
+ ((eq? 'begin (car term))
+ (for-each (lambda (x) (check-redefining! x #t)) term))
+ (else
+ (for-each (lambda (x) (check-redefining! x #f)) term)))))
+
+
+;=====================================================================
+;
+; Building closures
+;
+;====================================================================
+
+;(define *closure-name-suffix* "_cl")
+;(define *closure-name-nr* 0)
+;(define *closure-vector-name* "clargsv_")
+;(define *closure-vector-name-nr* 0)
+;(define *closurefun-arg* 'closurearg_0)
+;(define *closurefun-arg-car* 'closurearg_car_0)
+
+; The whole closurebuilding process is carried on top-down breadth-first:
+; there is no excplicit recursion. Instead, once a new closurefun def
+; is created, it is put into the list *lifted-closures-to-do*, which
+; is afterwards passed and the lambdaterms inside these new funs are
+; made into closures again, etc, until *lifted-closures-to-do* is empty.
+
+; try-closure-making-def is the topmost closure-builder applied to a def.
+
+(define (try-closure-making-def def)
+ (let* ((body (caddr def)))
+ (set! *letrec-closure-nr* 0)
+ (cond ((not (pair? body)) def)
+ ((eq? 'quote (car body)) def)
+ ((eq? 'lambda (car body)) (try-closure-making-ldef def))
+ (else (report-error "try-closure-making-non-ldef called")))))
+
+; try-closure-making-ldef builds closures for lambdaterm-defs.
+; It is never called from anywhere except try-closure-making-def
+; (the topmost closurebuilder)
+
+(define (try-closure-making-ldef def)
+ (let* ((lterm (caddr def))
+ (lvars (args->list (cadr lterm)))
+ (letvars (collect-local-vars (cddr lterm)))
+ (vars (union lvars letvars))
+ ;; closurevars is the subset of set! <vars> inside lambdas:
+ (closurevars (closure-building-vars (cddr lterm) vars))
+ (vectname (make-closure-vector-name)))
+ (set! *current-fun-name* (cadr def))
+ (if (null? closurevars)
+ ;; no set! closurevars found:
+ (list (car def) (cadr def)
+ (list* (car lterm) (cadr lterm)
+ (map (lambda (x)
+ (cdr (make-closure-making
+ x vars closurevars
+ *closurefun-arg-car* vectname)))
+ (cddr lterm))))
+ ;; in the next case some closurevars were found.
+ (let* ((tmp (make-closure-making
+ (cddr lterm) vars closurevars
+ *closurefun-arg-car* vectname))
+ (varsmapping (car tmp))
+ (newterm (cdr tmp))
+ (initialize-argsv
+ (make-initialize-closureargsv vectname lvars varsmapping)))
+ (if (not (null? varsmapping))
+ (beautify-closure
+ (list
+ (car def)
+ (cadr def)
+ (cons (car lterm)
+ (list (cadr lterm)
+ (cons 'let*
+ (cons (cons (list vectname
+ (list 'make-vector
+ (length closurevars)))
+ '())
+ (append initialize-argsv
+ newterm)))))))
+ (beautify-closure
+ (list
+ (car def)
+ (cadr def)
+ (cons (car lterm)
+ (list (cadr lterm)
+ (append initialize-argsv newterm))))))))))
+
+
+; make-closure-vector-name builds a new vector for these local vars
+; which are passed to (and set! inside) closures.
+; default: clargsv_
+;
+; It is called from try-closure-making-ldef, ..-non-ldef, ...-lterm.
+;
+; The created vector-name is added to *closure-var-vectornames*
+; for later recognition as such.
+
+(define (make-closure-vector-name)
+ (set! *closure-vector-name-nr* (+ 1 *closure-vector-name-nr*))
+ (let ((res (string->symbol
+ (string-append *closure-vector-name*
+ (number->string *closure-vector-name-nr*)))))
+ (if (not (memq res *closure-var-vectornames*))
+ (set! *closure-var-vectornames* (cons res *closure-var-vectornames*)))
+ res))
+
+; make-closure-name adds a suffix (default: _cl (+nr)) to the
+; argument functionname. The returned name will be used as a name
+; of the created closurefunction.
+;
+; called from: make-closure-making-aux and make-trivial-closuremaking
+
+(define (make-closure-name currentfunname)
+ (set! *closure-name-nr* (+ 1 *closure-name-nr*))
+ (string->symbol (string-append (symbol->string currentfunname)
+ *closure-name-suffix*
+ (number->string *closure-name-nr*))))
+
+; make-initialize-closureargsv takes a vectorname
+; (made by make-closure-vector for keeping local vars to be passed),
+; lvars (argument vars of a lambdaterm) and varsmapping
+; (mapping of local vars to be kept in vector 'vectorname' to the
+; elements of this vector)
+;
+; It adds vector-set! to each element of varsmapping and filters
+; out (keeps) exactly these which are in lvars. The resulting
+; sequence of assigments ... (set! (vector-ref clargsv_nrn nrx) x)
+; is inserted into function body after creating vector 'vectorname'
+; in order to use the vector-elements instead of the parametric vars
+; of the lambdaterm.
+;
+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm.
+
+(define (make-initialize-closureargsv vectname lvars varsmapping)
+ (filter-map (lambda (x)
+ (if (memq (car x) lvars)
+ (list 'vector-set! vectname
+ (cdr x) (car x))
+ #f))
+ varsmapping))
+
+; make-trivial-closuremaking is called in case the argument term
+; contains no mutable vars in the environment, ie when it does not have
+; to be a proper closure at all, but just a function without a
+; local environment. It returns just the name of the function, to
+; be inserted into the surrounding procedure at the place of the
+; original lambdaterm.
+;
+; called from: make-closuremaking-aux and try-closure-making-ldef, ...-lterm.
+
+(define (make-trivial-closuremaking term)
+ (cond
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((eq? 'lambda (car term))
+ (let* ((fun-name (make-closure-name *current-fun-name*))
+ (procname (make-closure-scmobj-name fun-name))
+ (newdef (list 'define fun-name term)))
+ (set! *lifted-trivial-closure-names*
+ (cons fun-name *lifted-trivial-closure-names*))
+ (set! *top-level-funs*
+ (cons fun-name *top-level-funs*))
+ (if (not (memq procname *special-c-vars*))
+ (set! *special-c-vars* (cons procname *special-c-vars*)))
+ (set! *lifted-closures-to-do*
+ (cons newdef *lifted-closures-to-do*))
+ procname))
+ ((not (list? term)) term)
+ (else
+ (map (lambda (x) (make-trivial-closuremaking x)) term))))
+
+; - - - - - - - - - proper closure-body-building begins - - - - - - - -
+
+
+; make-closure-making creates the correct body of the closure (inside
+; non-liftable lambdaterm which is used together with the vector
+; of its environment) together with the creation/instantiation code
+; inserted into the surrounding fun at the place of the original lambdaterm.
+;
+; vars is the set of environment vars, closurevars is the set of
+; set! environment vars.
+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm
+
+(define (make-closure-making term vars closurevars vectname clvectname)
+ (let* ((varsnr (length closurevars))
+ (tmp -1)
+ (clvarsmapping (map (lambda (x)
+ (set! tmp (+ 1 tmp)) (cons x tmp))
+ closurevars))
+ (newterm '()))
+ (set! newterm (vars->closureaccess
+ term '() clvarsmapping vectname clvectname))
+ (begin (set! newterm
+ (make-closure-making-aux
+ (cdr newterm) '() vars (map car clvarsmapping)
+ vectname clvectname))
+ (cons clvarsmapping newterm))))
+
+
+(define (make-closure-making-aux
+ term holes vars clvars vectname clvectname)
+ (cond
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((or (eq? 'lambda (car term)) (eq? *liftable-lambda* (car term)))
+ (make-closure-making-aux-lterm
+ term holes vars clvars vectname clvectname))
+ ((not (list? term)) term)
+ ((and (eq? 'set! (car term))
+ (pair? (cdr term))
+ (pair? (cddr term))
+ (pair? (caddr term))
+ ;; if it is not lambda, and is inside-term,
+ ;; then the set! var must be in clvars.
+ (eq? 'lambda (caaddr term))
+ (not (memq (cadr term) clvars))
+ (inside-term? (cadr term) (caddr term)))
+ (make-closure-making-aux-set!
+ term holes vars clvars vectname clvectname))
+ ((and (eq? 'letrec (car term))
+ (pair? (cdr term))
+ ;; if some bound var is inside-nonliftable-term,
+ ;; and some leading fun is not a (nonliftable)lambda,
+ ;; then all the bound vars must be in clvars.
+ (every1 (lambda (el) (eq? 'lambda (caadr el)))
+ (cadr term))
+ (find-if (lambda (el) (not (memq (car el) clvars)))
+ (cadr term)))
+ (make-closure-making-aux-letrec
+ term holes vars clvars vectname clvectname))
+ (else
+ (map (lambda (x)
+ (make-closure-making-aux
+ x holes vars clvars vectname clvectname))
+ term))))
+
+(define (make-closure-making-aux-set!
+ term holes vars clvars vectname clvectname)
+ (let* ((tmp '())
+ (newholes (cons (cadr term) holes)))
+ (set! *letrec-closures* '())
+ (set! *letrec-closure-init* '())
+ (set! tmp
+ (make-closure-making-aux
+ (caddr term) newholes vars clvars vectname clvectname))
+ (list* 'let* *letrec-closures*
+ (append (list (list 'set! (cadr term) tmp))
+ *letrec-closure-init*))))
+
+
+(define (make-closure-making-aux-letrec
+ letterm holes vars clvars vectname clvectname)
+ (let* ((bindings (cadr letterm))
+ (body (cddr letterm))
+ (newbindings '())
+ (newholes (append (map car bindings) holes)))
+ (set! *letrec-closures* '())
+ (set! *letrec-closure-init* '())
+ (set! newbindings
+ (map (lambda (el)
+ (list (car el)
+ (make-closure-making-aux
+ (cadr el) newholes vars clvars vectname clvectname)))
+ bindings))
+ (list* 'let* (append *letrec-closures* newbindings)
+ (append
+ *letrec-closure-init*
+ (map (lambda (x)
+ (make-closure-making-aux
+ x holes vars clvars vectname clvectname))
+ body)))))
+
+; make-closure-making-aux-lterm creates the correct body of the closure (inside
+; non-liftable lambdaterm which is used together with the vector
+; of its environment) together with the creation/instantiation code
+; inserted into the surrounding fun at the place of the original lambdaterm.
+;
+; vars is the set of environment vars, closurevars is the set of
+; set! environment vars.
+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm and
+; recursively from make-closure-making-aux
+
+(define (make-closure-making-aux-lterm
+ lterm holes vars clvars vectname clvectname)
+ (let ((params (args->list (cadr lterm))))
+ ;; filter out the subsets of vars actually occurring in lterm,
+ ;; previously throwing away these which are bound in lambda-args.
+ (or (null? vars)
+ (set! vars
+ (filter-inside-term
+ (filter (lambda (x) (not (memq x params)))
+ vars)
+ (cddr lterm))))
+ (cond
+ ((eq? *liftable-lambda* (car lterm))
+ (list* (car lterm) (cadr lterm)
+ (map (lambda (x)
+ (make-closure-making-aux
+ x holes vars clvars vectname clvectname))
+ (cddr lterm))))
+ ((and (null? vars)
+ (not (some-inside-term? *closure-var-vectornames* (cddr lterm))))
+ ;; trivial case: no closure has to be built, function suffices
+ (make-trivial-closuremaking lterm))
+ (else
+ ;; nontrivial case: closure has to be built, but there are no
+ ;; set! closurevars to be handled.
+ (let* ((fun-name (make-closure-name *current-fun-name*))
+ (definf (make-lifted-closure-fun
+ lterm fun-name vars clvars))
+ (applic (make-lifted-closure-applic definf holes)))
+ (set! *lifted-closure-names*
+ (cons fun-name *lifted-closure-names*))
+ (set! *lifted-closures-to-do*
+ (cons (caddr definf) *lifted-closures-to-do*))
+ applic)))))
+
+; make-lifted-closure-fun builds a body of the lambdaterm which is
+; used as a proper closure.
+;
+; vars is the (nonempty) list of free variables occurring in lterm
+;
+; make-lifted-closure-fun is called only from make-closure-making-aux.
+
+
+(define (make-lifted-closure-fun lterm name vars clvars)
+ (let* ((args (cdr (sort-out-clargs (cadr lterm))))
+ (passed-clargsv-lst
+ (filter-inside-term *closure-var-vectornames* (cddr lterm)))
+ (clargstranslation
+ (make-wrapped-clargs-init
+ passed-clargsv-lst *closurefun-arg-car* 1))
+ (varstranslation
+ (make-wrapped-clargs-init
+ vars *closurefun-arg-car* (+ 1 (length passed-clargsv-lst))))
+ (argstranslation
+ (make-wrapped-args-init
+ args *closurefun-arg* 1)))
+ (list
+ vars
+ passed-clargsv-lst
+ (list 'define
+ name
+ (list 'lambda
+ (list *closurefun-arg*)
+ (cons 'let*
+ (cons (append
+ (list (list *closurefun-arg-car*
+ (list 'car *closurefun-arg*)))
+ clargstranslation
+ varstranslation
+ argstranslation)
+ (cddr lterm))))))))
+
+
+; sort-out-clargs takes the parameters of the function to the used as
+; a closure-body. It splits these into the pair of two lists,
+; the car being all these parameters which are closure-var-vectornames
+; and the cdr being these parameters which are not.
+
+; called only from make-lifted-closure-fun.
+
+(define (sort-out-clargs inargs)
+ (let* ((clargs '())
+ (args '()))
+ (do ((part inargs (cdr part)))
+ ((not (pair? part))
+ (cons (reverse clargs)
+ (append (reverse args) part)))
+ (if (memq (car part) *closure-var-vectornames*)
+ (set! clargs (cons (car part) clargs))
+ (set! args (cons (car part) args))))))
+
+; make-wrapped-clargs-init takes a list of vars which are
+; closure-var-vectornames. It creates a let-initialization-list
+; of the form ((<listel> (vector-ref <closurefun-arg-car> 1) ... (..2) ...)
+
+; called only from make-lifted-closure-fun.
+
+(define (make-wrapped-clargs-init clargs varname nr)
+ (cond
+ ((null? clargs) '())
+ (else
+ (cons (list (car clargs) (list 'vector-ref varname nr))
+ (make-wrapped-clargs-init (cdr clargs) varname (+ 1 nr))))))
+
+
+; make-wrapped-args-init takes a list of vars which are _not_
+; closure-var-vectornames. It creates a let-initialization-list
+; of the form ((<listel> (begin (set! <closurefun-arg> (cdr closurefun-arg>))
+; (car <closurefun-arg>))).
+;
+; called only from make-lifted-closure-fun.
+
+(define (make-wrapped-args-init args varname nr)
+ (cond
+ ((null? args) '())
+ ((not (pair? args))
+ (list (list args (list 'cdr varname))))
+ ((zero? nr)
+ (cons (list (car args)
+ (list 'car varname))
+ (make-wrapped-args-init (cdr args) varname (+ 1 nr))))
+ (else
+ (cons (list (car args)
+ (list 'begin
+ (list 'set! varname (list 'cdr varname))
+ (list 'car varname)))
+ (make-wrapped-args-init (cdr args) varname (+ 1 nr))))))
+
+
+; make-lifted-closure-applic takes a newly built closurefun body def
+; and creates code for creating the closure and initializing the
+; environment-vector-part of the closure.
+;
+; called only from make-closure-making-aux.
+
+(define (make-lifted-closure-applic definf holes)
+ (let* ((vars (car definf))
+ (clvects (cadr definf))
+ (newdef (caddr definf))
+ (funname (cadr newdef))
+ (procname (make-closure-scmobj-name funname))
+ (lterm (caddr newdef))
+ (lbody (cddr lterm))
+ (assignments '())
+ (nr 0)
+ (closurename (string->symbol *new-closure-var*))
+ (letrec-assignments '()))
+ (if (not (null? holes))
+ (begin (set! *letrec-closure-nr* (+ 1 *letrec-closure-nr*))
+ (set! closurename
+ (string->symbol
+ (string-append
+ *new-closure-var*
+ (string-append
+ "_" (number->string *letrec-closure-nr*)))))))
+ (for-each (lambda (x)
+ (set! nr (+ 1 nr))
+ (set! assignments
+ (cons (list 'vector-set! closurename nr x)
+ assignments)))
+ clvects)
+ (for-each (lambda (x)
+ (set! nr (+ 1 nr))
+ (set! assignments
+ (cons (list 'vector-set! closurename nr x)
+ assignments)))
+ vars)
+ (cond ((null? holes) ; closure does not occur in letrec top
+ (if (null? assignments)
+ (list *make-cclo* procname (list *actual-c-int* (+ 1 nr)))
+ `(let* ((,closurename
+ (,*make-cclo*
+ ,procname ,(list *actual-c-int* (+ 1 nr)))))
+ ,@(reverse assignments)
+ ,closurename)))
+ (else
+ (set! letrec-assignments
+ (filter (lambda (x) (member (cadddr x) holes))
+ assignments))
+ (set! assignments
+ (filter (lambda (x) (not (member x letrec-assignments)))
+ assignments))
+ (set! *letrec-closures*
+ (append *letrec-closures*
+ (list (list closurename
+ (list *make-cclo* procname
+ (list *actual-c-int* (+ 1 nr)))))))
+ ; closure occurs in letrec top
+ (set! *letrec-closure-init*
+ (append *letrec-closure-init*
+ (reverse letrec-assignments)))
+ (if (null? assignments)
+ closurename
+ (cons 'begin (append assignments (list closurename))))))))
+
+
+;; - - - - - - - - - proper closure-body-building ends - - - - - - - -
+
+
+(define (make-closure-scmobj-name funname)
+ (let ((res (string->symbol
+ (string-append
+ (symbol->string funname) *closure-proc-suffix*))))
+ (or (memq res *special-c-vars*)
+ (set! *special-c-vars* (cons res *special-c-vars*)))
+ res))
+
+(define (list->conses lst)
+ (if (null? lst)
+ (list 'quote '())
+ (let ((tmp (list->conses (cdr lst))))
+ (list 'cons (car lst) tmp))))
+
+(define (cl-vectorname? symb)
+ (memq symb *closure-var-vectornames*))
+
+;vars->closureaccess takes a term and two mappings of vars to closureaccess.
+; a mapping has the format: (<var> . <nr>)
+;
+; it returns a pair (<flag> . <result-term>) where <flag> is #f iff
+; the term does not contain closurevars.
+;
+; it assumes that vars in let-s, lambda, do have been already renamed
+; so that there are no varname-clashes.
+;
+; called only from make-closure-making and recursively.
+
+(define (vars->closureaccess term varsmap clvarsmap vectname clvectname)
+ (cond
+ ((symbol? term)
+ (set! clvarsmap (assq term clvarsmap))
+ (set! varsmap (assq term varsmap))
+ (cond
+ ((and clvarsmap
+ (not (memq term *closure-var-vectornames*)))
+ (cons #t (list 'vector-ref clvectname (cdr clvarsmap))))
+ ((and varsmap
+ (not (memq term *closure-var-vectornames*)))
+ (cons #t (list 'vector-ref vectname (cdr varsmap))))
+ (else
+ (cons #f term))))
+ ((not (pair? term)) (cons #f term))
+ ((eq? 'quote (car term)) (cons #f term))
+ ((eq? *liftable-lambda* (car term))
+ (let* ((vars (args->list (cadr term)))
+ (newmap (filter (lambda (x) (not (memq (car x) vars))) varsmap))
+ (newclmap (filter (lambda (x) (not (memq (car x) vars))) clvarsmap))
+ (tmp (vars->closureaccess
+ (cddr term) newmap newclmap vectname clvectname)))
+ (cons (car tmp) (list* *liftable-lambda* (cadr term) (cdr tmp)))))
+ ((eq? 'lambda (car term))
+ (let* ((vars (args->list (cadr term)))
+ (newmap (filter (lambda (x) (not (memq (car x) vars))) varsmap))
+ (newclmap (filter (lambda (x) (not (memq (car x) vars))) clvarsmap))
+ (tmp (vars->closureaccess
+ (cddr term) newmap newclmap vectname clvectname)))
+ (if (car tmp) ; closurevars used?
+ ; yes, closurevars used:
+ (cons #t (cons 'lambda
+ (cons (cons clvectname (cadr term))
+ (cdr tmp))))
+ ; no, no closurevars were used:
+ (cons #f term))))
+ (else
+ (let ((tmp (map (lambda (x) (vars->closureaccess
+ x varsmap clvarsmap vectname clvectname))
+ term)))
+ (if (find-if (lambda (x) (car x)) tmp)
+ (cons #t (map cdr tmp))
+ (cons #f (map cdr tmp)))))))
+
+
+; closure-building-vars assumes that vars in the term are renamed
+; so that no varname or varname-funname or varname-syntax
+; conflicts occur.
+; it returns the subset of vars in funvars occurring freely and set!
+; inside lambdaterms in term, plus funvars fi occurring freely in the
+; contexts:
+; (1) (set! fi t), where t=/=(lambda (...)...) and fi occurs
+; inside a non-liftable lambdaterm in t.
+; (2) (letrec (... (fi ti) ...) ...), where ti=/=(lambda (...)...) and
+; at least one of fj bound in letrec occurs inside a non-liftable
+; lambdaterm in a tr body in letrec. NB! If some ti=/=(lambda (...)...),
+; the latter condition is automatically guaranteed by previous lifting
+; analysis.
+
+(define *closure-building-vars* '())
+
+(define (closure-building-vars term funvars)
+ (set! *local-vars* funvars)
+ (set! *closure-building-vars* '())
+ (closure-building-vars-aux! term)
+ (filter (lambda (x) (memq x *closure-building-vars*)) funvars))
+
+(define (closure-building-vars-aux! term)
+ (cond
+ ((not (pair? term)))
+ ((eq? 'quote (car term)))
+ ((eq? 'lambda (car term))
+ (for-each (lambda (var)
+ (if (and (not (memq var *closure-building-vars*))
+ (not (inside-term? var (cadr term)))
+ (inside-term-set? var (cddr term)))
+ (set! *closure-building-vars*
+ (cons var *closure-building-vars*))))
+ *local-vars*))
+ ((eq? *liftable-lambda* (car term))
+ (for-each closure-building-vars-aux! (cddr term)))
+ ((eq? 'set! (car term))
+ (if (and (pair? (caddr term))
+ (not (eq? 'lambda (car (caddr term))))
+ (inside-nonliftable-term? (cadr term) (caddr term))
+ (not (memq (cadr term) *closure-building-vars*)))
+ (set! *closure-building-vars*
+ (cons (cadr term) *closure-building-vars*)))
+ (for-each closure-building-vars-aux! (cdr term)))
+ ((eq? 'letrec (car term))
+ (if (and (find-if (lambda (x)
+ (and (pair? (cadr x))
+ (not (eq? 'lambda (car (cadr x))))))
+ (cadr term))
+ (find-if (lambda (x)
+ (find-if (lambda (y)
+ (inside-nonliftable-term? (car x) (cadr y)))
+ (cadr term)))
+ (cadr term)))
+ (for-each (lambda (x)
+ (or (memq (car x) *closure-building-vars*)
+ (set! *closure-building-vars*
+ (cons (car x) *closure-building-vars*))))
+ (cadr term)))
+ (for-each closure-building-vars-aux! (cdr term)))
+ (else
+ (for-each closure-building-vars-aux! term))))
+
+
+(define (inside-nonliftable-term? name term)
+ (cond
+ ((not (pair? term)) #f)
+ ((eq? 'quote (car term)) #f)
+ ((eq? 'lambda (car term))
+ (inside-term? name (cddr term)))
+ (else
+ (find-if (lambda (x) (inside-nonliftable-term? name x)) term))))
+
+(define (inside-term-set? x term)
+ (cond ((not (pair? term)) #f)
+ ((eq? 'quote (car term)) #f)
+ ((eq? 'set! (car term))
+ (or (and (pair? (cdr term))
+ (eq? x (cadr term))
+ (pair? (cddr term))
+ (null? (cdddr term)))
+ (inside-term-set? x (cdr term))))
+ (else
+ (or (inside-term-set? x (car term))
+ (inside-term-set? x (cdr term))))))
+
+(define (collect-local-vars term)
+ (set! *local-vars* '())
+ (collect-local-vars-aux term)
+ *local-vars*)
+(define (collect-local-vars-aux term)
+ (cond
+ ((not (pair? term)))
+ ((eq? (car term) 'quote))
+ ((or (eq? (car term) 'let*) (eq? (car term) *op-let*)
+ (eq? (car term) 'let) (eq? (car term) 'letrec))
+ (set! *local-vars*
+ (union (filter-map
+ (lambda (el)
+ (if (and (pair? (cadr el))
+ (eq? *liftable-lambda* (caadr el)))
+ #f
+ (car el)))
+ (cadr term))
+ *local-vars*))
+ (for-each (lambda (x) (collect-local-vars-aux (cadr x))) (cadr term))
+ (for-each (lambda (x) (collect-local-vars-aux x)) (cddr term)))
+ ((eq? (car term) 'do)
+ (set! *local-vars* (union (map car (cadr term)) *local-vars*))
+ (for-each (lambda (x)
+ (for-each (lambda (y) (collect-local-vars-aux y)) (cdr x)))
+ (cadr term))
+ (for-each (lambda (x) (collect-local-vars-aux x)) (caddr term))
+ (for-each (lambda (x) (collect-local-vars-aux x)) (cdddr term)))
+ ((eq? (car term) 'lambda))
+ (else
+ (for-each (lambda (x) (collect-local-vars-aux x)) term))))
+
+; beautify-closure takes a built closure-fun and corrects the
+; following: (let* (... ((vector-ref foo n) bar) ...) ...) is
+; replaced by (let* (...) (vector-set! foo n bar) (let* (...) ...)),
+; (set! (vector-ref foo n) bar) is replaced by (vector-set! foo n bar)
+(define (beautify-closure term)
+ (cond
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ ((and (eq? 'set! (car term))
+ (pair? (cdr term))
+ (pair? (cadr term))
+ (eq? 'vector-ref (caadr term))
+ (pair? (cdadr term))
+ (pair? (cddr term))
+ (memq (cadadr term) *closure-var-vectornames*))
+ (list 'vector-set!
+ (cadadr term) (caddr (cadr term)) (beautify-closure (caddr term))))
+ ((and (memq (car term) '(let* let letrec))
+ (not (null? (cdr term)))
+ (pair? (cadr term))
+ (find-if (lambda (x) (pair? (car x))) (cadr term)))
+ (beautify-closure-let (car term) (cadr term) (cddr term)))
+ ((list? term)
+ (map beautify-closure term))
+ (else
+ term)))
+(define (beautify-closure-let key bindings rest)
+ (if (null? bindings)
+ (cons 'begin (map beautify-closure rest))
+ (let* ((okpart '()))
+ (do ((part bindings (cdr part)))
+ ((or (null? part)
+ (and (pair? (car part))
+ (pair? (caar part))
+ (eq? 'vector-ref (caaar part))
+ (pair? (cdaar part))
+ (memq (cadaar part) *closure-var-vectornames*)))
+ (if (null? part)
+ (list* key (reverse okpart) (map beautify-closure rest))
+ (list key
+ (reverse okpart)
+ (list 'vector-set! (cadaar part)
+ (caddar (car part))
+ (beautify-closure (cadar part)))
+ (beautify-closure-let key (cdr part) rest))))
+ (set! okpart (cons (list (caar part)
+ (beautify-closure (cadar part)))
+ okpart))))))
+
+
+
+;====================================================================
+;
+; auxiliary functions - a library
+;
+;===================================================================
+
+(define (filter f lst)
+ (cond ((null? lst) '())
+ ((f (car lst)) (cons (car lst) (filter f (cdr lst))))
+ (else (filter f (cdr lst)))))
+
+(define (filter-map f lst)
+ (if (pair? lst)
+ (let ((res (f (car lst))))
+ (if res
+ (cons res (filter-map f (cdr lst)))
+ (filter-map f (cdr lst))))
+ '()))
+
+(define (filter-inside-term lst term)
+ (define *filter-inside-term-res* '())
+ (define (filter-inside-term-aux! lst term)
+ (cond ((not (pair? term))
+ (and (memq term lst)
+ (not (memq term *filter-inside-term-res*))
+ (set! *filter-inside-term-res*
+ (cons term *filter-inside-term-res*))))
+ ((eq? 'quote (car term)))
+ (else (filter-inside-term-aux! lst (car term))
+ (filter-inside-term-aux! lst (cdr term)))))
+ (filter-inside-term-aux! lst term)
+ (filter (lambda (x) (memq x *filter-inside-term-res*)) lst))
+
+(define (inside-term? x term)
+ (cond ((eq? x term) #t)
+ ((not (pair? term)) #f)
+ ((eq? 'quote (car term)) #f)
+ (else (or (inside-term? x (car term))
+ (inside-term? x (cdr term))))))
+
+(define (some-inside-term? obs term)
+ (cond ((memq term obs) #t)
+ ((not (pair? term)) #f)
+ ((eq? 'quote (car term)) #f)
+ (else (or (some-inside-term? obs (car term))
+ (some-inside-term? obs (cdr term))))))
+
+(define (subst-term-equal! what for term)
+ (cond ((not (pair? term)))
+ ((equal? (car term) for)
+ (set-car! term what)
+ (subst-term-equal! what for (cdr term)))
+ ((not (eq? 'quote (car term)))
+ (subst-term-equal! what for (car term))
+ (subst-term-equal! what for (cdr term)))))
+
+(define (subst-term what for term)
+ (cond ((eq? term for) what)
+ ((not (pair? term)) term)
+ ((eq? 'quote (car term)) term)
+ (else (cons (subst-term what for (car term))
+ (subst-term what for (cdr term))))))
+
+(define (in-fun-position? x term)
+ (cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)
+ ((not (list? term)) #f)
+ ((eq? x (car term)) #t)
+ (else (find-if (lambda (y) (in-fun-position? x y)) term))))
+
+(define (some-in-fun-position? lst term)
+ (cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)
+ ((not (list? term)) #f)
+ ((memq (car term) lst) #t)
+ (else (find-if (lambda (y) (some-in-fun-position? lst y)) term))))
+
+(define (replaceq what with lst)
+ (cond ((null? lst) '())
+ ((eq? what (car lst)) (cons with (replaceq what with (cdr lst))))
+ (else (cons (car lst) (replaceq what with (cdr lst))))))
+
+;;; Like LAST-PAIR, but works for non-lists.
+(define (my-last-pair lst)
+ (define (my-last-pair-aux lst)
+ (if (pair? (cdr lst))
+ (my-last-pair-aux (cdr lst))
+ lst))
+ (if (not (pair? lst))
+ lst
+ (my-last-pair-aux lst)))
+
+;;; Like REMOVE, but removes at most one element.
+(define (remove-one what from)
+ (cond ((null? from) from)
+ ((eq? what (car from)) (cdr from))
+ (else (cons (car from) (remove-one what (cdr from))))))
+
+;;; Like FIND-IF, but works for non-lists.
+(define (pair-find-if f lst)
+ (if (pair? lst)
+ (if (f (car lst)) (car lst) (pair-find-if f (cdr lst)))
+ (if (f lst) lst #f)))
+
+;;; slib/comlist.scm functions:
+
+(define (find-if f lst)
+ (if (null? lst)
+ #f
+ (if (f (car lst)) (car lst) (find-if f (cdr lst)))))
+
+(define (remove what lst)
+ (cond ((null? lst) '())
+ ((eq? what (car lst)) (remove what (cdr lst)))
+ (else (cons (car lst) (remove what (cdr lst))))))
+
+(define (every1 f lst)
+ (if (null? lst)
+ #t
+ (if (f (car lst)) (every1 f (cdr lst)) #f)))
+
+(define (member-if f lst)
+ (if (null? lst)
+ #f
+ (if (f (car lst)) lst (member-if f (cdr lst)))))
+
+(define (list* obj1 . obj2)
+ (define (list*1 obj)
+ (if (null? (cdr obj))
+ (car obj)
+ (cons (car obj) (list*1 (cdr obj)))))
+ (if (null? obj2)
+ obj1
+ (cons obj1 (list*1 obj2))))
+
+(define (butlast lst n)
+ (letrec
+ ((len (- (length lst) n))
+ (bl (lambda (lst n)
+ (let build-until-zero ((lst lst)
+ (n n)
+ (result '()))
+ (cond ((null? lst) (reverse result))
+ ((positive? n)
+ (build-until-zero
+ (cdr lst) (- n 1) (cons (car lst) result)))
+ (else (reverse result)))))))
+ (bl lst (if (negative? n)
+ (slib:error "negative argument to butlast" n)
+ len))))
+
+(define (union lst1 lst2)
+ (define ans (if (null? lst1) lst2 lst1))
+ (define (adjoin obj lst) (if (memv obj lst) lst (cons obj lst)))
+ (cond ((null? lst2) lst1)
+ (else (for-each (lambda (elt) (set! ans (adjoin elt ans)))
+ lst2)
+ ans)))
+
+(define (set-difference lst1 lst2)
+ (if (null? lst2)
+ lst1
+ (let build-difference ((lst1 lst1)
+ (result '()))
+ (cond ((null? lst1) (reverse result))
+ ((memv (car lst1) lst2) (build-difference (cdr lst1) result))
+ (else (build-difference (cdr lst1) (cons (car lst1) result)))))))
+
+(define (intersection lst1 lst2)
+ (if (null? lst2)
+ lst2
+ (let build-intersection ((lst1 lst1)
+ (result '()))
+ (cond ((null? lst1) (reverse result))
+ ((memv (car lst1) lst2)
+ (build-intersection (cdr lst1) (cons (car lst1) result)))
+ (else
+ (build-intersection (cdr lst1) result))))))
+
+;=========================== END ===============================
|