From deda2c0fd8689349fea2a900199a76ff7ecb319e Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:26 -0800 Subject: Import Upstream version 5d6 --- hobbit.scm | 6981 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 6981 insertions(+) create mode 100644 hobbit.scm (limited to 'hobbit.scm') 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 ? : +;;; to the code which may evaluate BOTH and 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 || +;;; to the code which may evaluate even if evaluates to 1, +;;; or, analogically, && may evaluate even if +;;; 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 _ 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 ) + (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<=?) (char-ci>=? char-ci<=?) + (string>? string? 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) + + (charinteger "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) (stringlist "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)))) + + + ;;; ( ) + +(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 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: ( ), +;;; where 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-ci=? chr) (char-ci? chr) + (char-ci<=? chr) (char-ci>=? chr) + (string=? str) (string? str) (string<=? str) (string>=? 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! 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 (( (vector-ref 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 (( (begin (set! (cdr closurefun-arg>)) +; (car ))). +; +; 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: ( . ) +; +; it returns a pair ( . ) where 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 =============================== -- cgit v1.2.3