;====================================================================
;
;            HOBBIT is a small scheme -> C compiler for scm
;
;		 Copyright (C) 1992, 1993 Tanel Tammet
;			tammet@cs.chalmers.se
;
;		    Tanel Tammet
;		    Department of Computer Sciences
;		    Chalmers University of Technology
;		    University of Go"teborg
;		    S-41296 Go"teborg
;		    Sweden
;
;		       Terms for usage, copying
;	    and redistribution are given in the file hobbit.tms
;
;		Documentation is in the file hobbit.doc
;
;			     version 2
;
;
;====================================================================

;====================================================================
;
;  Scheme-implementation-specific definitions. Change if needed.
;
;   You do need to change them if you want to self-compile hobbit!
;
;====================================================================

;;; Redefine the following if you do not have 'abort' in your scheme

(define (report-error . lst)
  (display #\newline)
  (display "COMPILATION ERROR: ")
  (display #\newline)
  (for-each display lst)
  (display #\newline)
  (abort) )

;;; Redefine 'pretty-print' to any printing-function if you do not have
;;; pretty-print in your scheme.
;;; Remove '(require 'pretty-print)' if you do not have 'require'
;;; in your scheme
;;;
;;; NB! those two changes are required to self-compile hobbit.

(require 'pretty-print)

;;; (define pretty-print (lambda(x port)(display x port)))

;================================================================
;
;		 C-specific and system-specific options
;
;===============================================================

;;; If your C compiler does not assume that integers without a cast
;;; are long ints, you may need to set the following flag to #t.
;;; In that case all integers in the output C text, which should
;;; be long ints, will have a trailing L cast.

(define *long-cast-flag* #f)

;;; If your C compiler may compile the C operator <test> ? <r1> : <r2>
;;; to the code which may evaluate BOTH <r1> and <r2> in one
;;; evaluation of the whole operator, you MUST define *lift-ifs-flag*
;;; as #t.

(define *lift-ifs-flag* #f)

;;; If you C compiler may compile the C operator <a1> || <a2>
;;; to the code which may evaluate <a2> even if <a1> evaluates to 1,
;;; or, analogically, <a1> && <a2> may evaluate <a2> even if
;;; <a1> evaluates to 0, you MUST define *lift-and-or-flag* as #t.

(define *lift-and-or-flag* #f)

;;; The following flag may be false only if the output C program
;;; is supposed to run only on systems where the following holds:
;;; ((-1%2 == -1) && (-1%-2 == -1) && (1%2 == 1) && (1%-2 == 1).
;;; Otherwise the following flag must be #t.

(define *badivsgns-flag* #f)

;;; *input-file-modifier* and *output-file-modifier*
;;; are strings which are given to the C file-opener to
;;; indicate the mode of the file to be opened.
;;; Select the MSDOS or ATARI version if appropriate, or define
;;; your own modifier-strings.

(define *input-file-modifier* "r")     ;;; for UNIX & others
(define *output-file-modifier* "w")    ;;; for UNIX & others

;;; (define *input-file-modifier* "rb")    ;;; for MSDOS & ATARI
;;; (define *output-file-modifier* "wb")   ;;; for MSDOS & ATARI

;=================================================================
;
;		   default compiler options
;		      (may be changed)
;
;=================================================================

;;; The following variable controls whether functions declared
;;; to be inlined are inlined in full or only once. If the set of
;;; 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.

(define *build-intermediate-files* #f)

;;; The following variable controls optimizations of integer
;;; arithmetic for scheme<->C type conversions.

(define *optimize-arithmetic* #f)      ; MUST be #f in this version

;;; 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)

;;; 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
(define *floats-flag* #f)              ; MUST be #f in this version

;=================================================================
;
;			renamable constants
;	       (you might need to change some of these to
;			avoid name clashes)
;
;=================================================================

;;; 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 acons lnot booleanp eq equal consp cons nullp
 setcar setcdr listp list length append reverse list-ref memq memv
 member assq assoc symbolp symbol2string string2symbol numberp exactp
 inexactp eqp lessp zerop positivep negativep oddp evenp lmax lmin sum
 product difference quotient absval 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))


;;; 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_")

;;; 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 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 a name of a function generated to initialize
;;; non-function defined variables in your scheme file.

(define *init-vars-fun* 'init_global_vars)

;;; The following is a name of a function generated to initialize
;;; constants in your scheme file.

(define *init-constants-fun* 'init_constant_vars)

;;; 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 you scheme file.

(define *inline-declare* 'compile-inline)

;;; 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)

;;; 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_")
    (#\- "_")
    (#\. "_dot_")
    (#\* "_star_")
    (#\/ "_slash_")
    (#\< "_less_")
    (#\= "_equal_")
    (#\> "_grtr_")
    (#\! "_excl_")
    (#\? "_pred_")
    (#\: "_colon_")
    (#\$ "_dollar_")
    (#\% "_percent_")
    (#\_ "_")
    (#\& "_and_")
    (#\~ "_tilde_")
    (#\^ "_exp_") ))

;;; *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* "NIL")
(define *scm-type* "SCM")
(define *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 *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**)
(define *goto-tailrec* '**goto-tailrec**)
(define *mark-tailrec* '**mark-tailrec**)
(define *define-constant* '**define-constant**)
(define *actual-c-string* '**actual-c-string**)
(define *global-access*   '**global-access**)
(define *sysapply* '**sysapply**)
(define *listofnull* '**listofnull**)

(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*
*global-access*
*listofnull*
*sysapply*))


;;; *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.
;;; 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 *internal-c-functions*
  (list *intern-function* *makfromstr-function* *intern-symbol-function*) )

(define *prohibited-funs* '())

(define *restricted-funs*
  '(call-with-current-continuation call-cc call/cc callcc
    apply force delay))

;;; *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.
;;;
;;; *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*
 (append
       (if *badivsgns-flag*
	   '()
	   '(quotient remainder) )
       (if *floats-flag*
	   '()
	   '(/) )
       '(logxor lognot logsleft logsright 
          = < > <= >= + - *) ))
(define *num-res-c-funs*
 (append
       (if *badivsgns-flag*
	   '()
	   '(quotient remainder) )
       (if *floats-flag*
	   '()
	   '(/) )
       '(logxor lognot logsleft logsright 
         + - *) ))

(define *bool-arg-c-funs*
  (cons *and?* (cons *or?* (list *not?*))) )

(define *bool-res-c-funs*
  (cons *and?*
	(cons *or?*
	      (cons *not?*
		     '(boolean? symbol? char? vector? pair? number?
		       string? procedure?
		       eq? eqv? char=? null? zero? negative? positive?
		       = < > <= >=)))))

;;; 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
;
;=================================================================

(define *map1-needed-flag* #f)
(define *for-each1-needed-flag* #f)
(define *constant-list-var* '())
(define *inline-funs* '())
(define *var-init-list* '())
(define *inline-funs-data* '())
(define *c-port* '())
(define *h-port* '())
(define *char-replacements-lists* '())
(define *tmp-var-max* 100)
(define *initial-defs* '())
(define *passed-defs* '())
(define *output-defs* '())
(define *new-funs-list* '())
(define *fun-arities-alist* '())
(define *to-do-fun-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-order-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 *new-constant-num* 0)
(define *passed-ho-dot-instfuns* '())
(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* '())

;;; 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)))
	       (fn (car lst))
	       (set! lst (cdr lst)) ))))

;=================================================================
;
;			     top level
;
;=================================================================


(define (hobbit file . files)
   (init-global)
   (set! *initial-defs* '())
   (for-each (lambda(x)
	       (newline)
	       (display "Starting to read ")(display x)
	       (compile-aux x) )
	     (cons file files) )
   (newline)
   (display "Starting compilation.")
   (compile-defs file (reverse *initial-defs*)) )

(define (Hobbit:compile file . files)
   (init-global)
   (set! *initial-defs* '())
   (for-each (lambda(x)
	       (newline)
	       (display "Starting to read ")(display x)
	       (compile-aux x) )
	     (cons file files) )
   (newline)
   (display "Starting compilation.")
   (compile-defs file (reverse *initial-defs*)) )

(define (compile-aux file)
   (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) )))
	 (def #t) )
     (do ()
	 ((eof-object? def)
	    (close-input-port iport) )
	 (set! def (read iport))
	 (cond ((eof-object? def))
	       ((not (pair? def))
		  (close-input-port iport)
		  (report-error
		   "The following object is neither a definition nor load: "
		   def))
	       ((or (eq? 'load (car def))
		    (eq? 'require (car def)) )
		  (if (or (not (pair? (cdr def)))
			  (not (string? (cadr def))) )
		      (begin (close-input-port iport)
			     (report-error "Wrong load: " def) ))
		  (newline)
		  (display "Reading auxiliary file: ")
		  (display (cadr def))
		  (compile-aux (cadr def))
		  (newline)
		  (display "Auxiliary file ")(display (cadr def))
		  (display " successfully read.")
		  (newline) )
	       (else
		  (set! *initial-defs* (cons def *initial-defs*)) )))))

(define (file-exists? str)
  (let ((port (open-file str *input-file-modifier*)))
    (if port (begin (close-port port) #t)
        #f)))

(define (compile-defs file deflst)
  (let ()
    (set! file (descmify file))
    (sort-out-deflst! deflst file)
    (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 *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.") )
	(begin
	  (newline)
	  (display "lambda-lifting-&-normalization pass has been finished.") ))
    (set! *to-do-fun-list* *passed-defs*)
    (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 *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.") )
	(begin
	  (newline)
	  (display "statement-lifting pass has been finished.") ))
    (set! *to-do-fun-list* *passed-defs*)
    (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*)))
    (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.") )
	(begin
	  (newline)
	  (display "higher-order-&-dot-correction pass has been finished.") ))
    (set! *to-do-fun-list* *passed-defs*)
    (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*))))
    (set! *passed-defs* (reverse *passed-defs*))
    (make-initialization-function! file)
    (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) )
	(begin
	  (newline)
	  (display "typing-&-constant-correcting pass has been finished.")
	  (newline) ))
    (set! *to-do-fun-list* *passed-defs*)
    (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)
       (display "C definitions 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) (write-c-*declaration x fport))
		 (cons *constant-list-var*  *global-vars-list*) )
       (for-each (lambda(x) (write-c-static-declaration (cadr x) fport))
		 (reverse *symbol-constant-table*) )
       (for-each (lambda(x) (write-c-static-declaration (cadr x) fport))
		 (reverse *new-constant-list*) )
       (newline fport)
       (close-output-port fport)
       (display "header file ")
       (display (string-append file '".h"))
       (display " is built.")
       (newline) )
    (if (not (null? *unknown-functions*))
	(begin (newline)
	  (display
   "The following functions are assumed to be defined via interpreter:")
	  (newline)
	  (display *unknown-functions*)
	  (newline) ))
    (if (not (null? *unknown-vars*))
	(begin (newline)
	  (display
   "The following variables undefined (but used) in your file were defined:")
	  (newline)
	  (display *unknown-vars*)
	  (newline) ))
    (newline) ))

(define (sort-out-deflst! lst file)
  (set! *to-do-fun-list* '())
  (set! *inline-funs* '())
  (set! *var-init-list* '())
  (set! *global-vars-list* '())
  (set! *var-make-list* '())
  (set! *constant-list-var*
	 (string->symbol (string-append *protect-variable* file)) )
  (do ((part lst (cdr part)))
      ((null? part))
      (let ((el (car part)))
	(cond
          ((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))
	  ((or (pair? (cadr el))
	       (and (not (null? (cddr el)))
		    (pair? (caddr el))
		    (eq? 'lambda (car (caddr el))) ))
	     (set! *to-do-fun-list* (cons el *to-do-fun-list*)) )
	  ((eq? (cadr el) *inline-declare*)
	     (set! *inline-funs* (append (cadr (caddr el)) *inline-funs*)) )
	  ((eq? (cadr el) *export-declare*)
	   (set! *export-functions*
		 (append (cadr (caddr el))
			 (if (pair? *export-functions*)
			      *export-functions*
			      '()))))
	  ((null? (cddr el))
             (set! *global-vars-list* (cons (cadr el) *global-vars-list*))
	     (set! *var-init-list*
		   (cons (list 'set! (cadr el) *unspecified*)
			 *var-init-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
	     (set! *global-vars-list* (cons (cadr el) *global-vars-list*))
	     (set! *var-init-list*
		   (cons (cons 'set! (cdr el))
			 *var-init-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? *var-init-list*))
      (set! *to-do-fun-list*
	    (cons (list 'define
			*init-vars-fun*
			(list* 'lambda
			       '()
			       (reverse (cons '() *var-init-list*)) ))
		  *to-do-fun-list*)))
  (set! *to-do-fun-list* (reverse *to-do-fun-list*))
  (set! *inline-funs-data* '())
  (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* (delete (car part) *inline-funs*)) ))))

(define (make-inline-body def)
  (let* ((tmp (rename-vars
	       (lettify-lambdas
		(normalize-defines
		 (compile-quasiquote def))
		200)))
	 (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* ((constant-list
	    (list
	     `(set! ,*constant-list-var*
		    (,*c-adr*
		       (cdr
			  (,*intern-function*
			     (,*actual-c-string*
				,(symbol->string *constant-list-var*) )
			     ,(string-length
				 (symbol->string *constant-list-var*) )))))
	     (list 'set!
		   (list *global-access* *constant-list-var*)
		   (make-init-fun-aux
		      (map cadr *new-constant-list*) ))))
	  (init-all
	   (list 'define
		 (make-initfun-name file)
		 (list 'lambda
		       '()
		       (list* 'let* '()
                          (append
			     (init-export-funs)
			     *var-make-list*
			     (reverse *symbol-list*)
			     (reverse *new-constant-list*)
			     constant-list
			     (if (null? *var-init-list*)
				 '()
				 (list (list *init-vars-fun*)) )))))))
     (set! *passed-defs* (append *passed-defs* (list init-all))) ))

(define (init-export-funs)
  (let ((res '()))
    (set! *export-functions*
	  (delete *init-vars-fun* *export-functions*) )
    (for-each
       (lambda(x)
	 (if (memq (cadr x) *export-functions*)
	     (let* ((tmp1 (assq (cadr x) *export-table*))
		    (tmp (assq (cadr x) *wrapper-table*))
		    (arity '())
		    (flag '()) )
	       (cond (tmp (set! arity 'x))
		     ((begin
			(set! arity (assq (cadr x) *dot-arg-templates*))
			(and arity
			     (symbol? (cadr arity)) ))
		       (set! arity 'x) )
		     (else (set! arity (cadr (caddr x)))) )
	       (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
		     (cons (list 'make_subr
				 (list *actual-c-string*
				       (symbol->string (cadr x)) )
				 flag
				 (if tmp
				     (cadr tmp)
				     (if tmp1
					 (cadr tmp1)
					 (cadr x) )))
			   res)))))
       *passed-defs*)
    (reverse res) ))


(define (make-init-fun-aux lst)
  (if (pair? lst)
      (list 'cons (car lst) (make-init-fun-aux (cdr lst)))
      '()))

(define (make-initfun-name file)
  (string->symbol (string-append *init-fun-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 (headerline s)
  (display s *h-port*)
  (newline *h-port*) )

(define (display-header fport)
  (set! *h-port* fport)

  (headerline "#include \"scm.h\" ")
  (headerline ""))

(define (init-global)
   (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! *new-constant-num* 0)
   (set! *char-replacements-lists* '())
   (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! *export-functions* #f)
   (set! *export-table* '())
   (set! *wrapper-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*)) )


;=================================================================
;
;		  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 (not (null? (cadr top-let)))
       (begin
	 (display-c-indent 1)
	 (display-c *scm-type*)
	 (display-c #\space)
	 (display-c-lst (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 (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 ((or (char? prefix)(string? prefix))
			     (display-c prefix)
			     (display-c-expression x #t) )
			  ((eq? 'function prefix)
			     (display-c "(*")
			     (display-c-expression x #t)
			     (display-c ")()") )
			  (else
			     (display-c-expression x #t) ))
		    (display-c separator) )
		  (butlast lst) )
	(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) )
  (else
   (let* ((str (symbol->string var))
	  (char '())
	  (replacement '())
	  (len (string-length str))
	  (global-flag #f) )
     (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 (some (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 "(unsigned char *)")
	(write-c-string (car args)) )
     ((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 (cdr 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 (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 *switch-args-table*
  '((char>? char<?)(char-ci>? char-ci<?)
    (char>=? char<=?)(char-ci>=?  char-ci<=?)
    (string>?  string<?)(string-ci>? string-ci<?)
    (string-ci>=? string-ci<=?)(string>=? string<=?) ))

(define *add-args-table*
 (append
  (list
    (list 'make-vector #\space 2)
    (list 'number->string (list *num-c->s* 10) 2)
    (list 'string->number (list *num-c->s* 10) 2) )
  '((make-string #\space 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*
 '((cons "cons" 2)(car "CAR" 1)(cdr "CDR" 1)
   (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)(assq "assq" 2)(assv "assv" 2)
   (assoc "assoc" 2)
;;;  (last-pair "last_pair" 1)

   (symbol->string "symbol2string" 1)(string->symbol "string2symbol" 1)

   (exact? "exactp" 1)(inexact? "inexactp" 1)
   (odd? "oddp" 1)(even? "evenp" 1)(max "lmax" 2)(min "lmin" 2)(abs "absval" 1)
   (quotient "quotient" 2)(remainder "lremainder" 2)
   (modulo "modulo" 2)(gcd "lgcd" 2)(lcm "llcm" 2)(floor "floor" 2)
   (ceiling "ceil" 1)(truncate "ltrunc" 1)(round "round" 1)
   (sin "sin" 1)(cos "cos" 1)(tan "tan" 1)(asin "asin" 1)
   (acos "acos" 1)(atan "atan" 1)(sqrt "sqrt" 1)(expt "expt" 2)
   (make-rectangular "makrect" 2)(make-polar "makpolar" 2)
   (real-part "real_part" 1)(imag-part "imag_part" 1)
   (magnitude "magnitude" 1)(angle "angle" 1)

   (number->string "number2string" 2)(string->number "string2number" 1)

   (char<? "char_lessp" 2)(char<=? "char_leqp" 2)
   (char-ci=? "chci_eq" 2)(char-ci<? "chci_lessp")
   (char-ci<=? "chci_leqp" 2)

   (char-alphabetic? "char_alphap" 1)(char-numeric? "char_nump" 1)
   (char-whitespace? "char_whitep" 1)(char-upper-case? "char_upperp" 1)
   (char-lower-case? "char_lowerp" 1)

   (char->integer "char2int" 1)(integer->char "int2char" 1)
   (char-upcase "char_upcase" 1)(char-downcase "char_downcase" 1)

   (make-string "make_string" 2)
   (string "string" 1)
   (string-length "st_length" 1)
   (string-ref "st_ref" 2)
   (string-set! "st_set" 3)
   (substring "substring" 3)
   (string-append "st_append" 1)
   (list->string "string" 1)
   (string->list "string2list" 1)
   (string-copy "string_copy" 1)
   (string-fill! "string_fill" 2)
   (string=? "st_equal" 2)(string<? "st_lessp" 2)(string<=? "st_leqp" 2)
   (string-ci=? "stci_equal" 2)(string-ci<? "stci_lessp")
   (string-ci<=? "stci_leqp" 2)

   (make-vector "make_vector" 2)
   (vector "vector" 1)
   (vector-length "vector_length" 1)
   (vector-ref "vector_ref" 2)
   (vector-set! "vector_set" 3)
   (vector->list "vector2list" 1)
   (list->vector "vector" 1)

   (read "lread" 1)
   (read-char "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)
;   (gc "gc" 0)
   (quit "quit" 1)
   (abort "abrt" 0)
   (restart "restart" 0)
   (chdir "chdir" 1)
   (delete-file "del_fil" 1)
   (rename-file "ren_fil" 2) ))


 ;;; (<s-fn> <c-fn> <nr-args> <infix-flag> <c-flag>)

(define *reckless-s->c-fun-table*
 (append

  (if *badivsgns-flag*
      '()
      '((quotient "/" 2 #t #t)
	(remainder "%" 2 #t #t) ))

  (cond (*floats-flag* '())
	(*badivsgns-flag* '())
	(else '((/  "/" 2 #t #t)) ))

  (list
   (list *sysapply* "apply" 3 #f #f)
   (list *global-access* "GLOBAL" 1 #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* "NUM" 1 #f #f)
   (list *num-c->s* "SNUM" 1 #f #f)
   (list *bool-s->c* "BOOL" 1 #f #f)
   (list *bool-c->s* "SBOOL" 1 #f #f)
   (list *char-c->s* "SCHAR" 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? "COMPLEX_P" 1 #f #t)
;   (real?    "REAL_P"    1 #f #t)
;   (rational? "RATIONAL_P" 1 #f #t)
   (integer?  "INTEGER_P" 1 #f #t)
   (string?  "STRING_P"  1 #f #t)
;   (procedure? "PROCEDURE_P" 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)

   (/        "quotient"  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*)
      (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 (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 (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 term)
 (let ((res
	(cond
	 ((string? term)
	     (make-string-constant term) )
	 ((char? term)
	     (list *char-c->s* term) )
         ((vector? term)
	     (make-vector-constant term) )
	 ((number? term)
	    (list *num-c->s* term) )
	 ((symbol? term)
	    (cond ((or (memq term *local-parameters*)
		       (memq term *local-vars*)
		       (memq term *special-scm->c-functions*) )
		     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? '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 *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) '(= < <= > >=))
			 (if (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))) )
			     (list *bool-c->s* tmp2) ))
		     ((memq (car term) *bool-res-c-funs*)
			(list *bool-c->s* tmp2) )
		     (else
			tmp2))))
	 ((or (eq? 'eq? (car term))
	      (eq? 'char=? (car term))
	      (and (not *floats-flag*)
		   (or (eq? 'eqv? (car term))
		       (eq? '= (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*) )
		   (if (memq (car term) *bool-res-c-funs*)
		       (list *bool-c->s* (cons (car term) (map cadr tmp)))
		       (cons (car term) (map cadr tmp)) )
		   (if (memq (car term) *bool-res-c-funs*)
		       (list *bool-c->s* (cons (car term) tmp))
		       (cons (car term) tmp) ))))
	 ((memq (car term) *bool-arg-c-funs*)
	     (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)))
	 ((memq (car term) *bool-res-c-funs*)
	     (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*)
		      (list *function* (cadr term)) )
		   ;  (report-error
		   ;    "In " *current-fun-name* " compiled function "
		   ;    (cadr term) " occurs as an argument. Use lambdaterm!"))
		  ((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!"))))
         ((memq (car term)  *cxr-funs*)
             (cxr-open (car term) (type-const-pass (cadr term))) )
	 ((unknown-function? (car term) (cdr term))
	    (make-unknown-call term) )
	 (else
	     (cons (car term)
		   (map type-const-pass (cdr term)) )))))
   (if (and (pair? res) (or (eq? 'begin (car res))
			    (eq? *op-begin* (car res)) ))
       (cons (car res)(begins->list (cdr res)))
       res) ))

(define (unknown-function? fn args)
  (let ((len (length args)))
    (or
     (pair? 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 (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))
	(args (map type-const-pass (cdr term)))
	(glob '()) )
    (if (pair? fn)
	(set! glob (make-unknown-call-aux term args))
        (set! glob (list *global-access* (make-unknown-constant fn))) )
    (if (memq fn *restricted-funs*)
	(if (or (not (pair? (cdr term)))
		(in-file-defined? (cadr term)) )
	    (report-error
	      "In " *current-fun-name* " a function " fn
	      " is applied to a compiled function " (cadr term))))
    (or (pair? fn)
	(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-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 *makfromstr-function*
			    (list *actual-c-string*
				  str)
			    (string-length str) ))
		   ;;;   (list 'list->string
		   ;;;	    (type-const-pass
		   ;;;	       (normalize-list-aux
		   ;;;		  (string->list str) )))
		*new-constant-list*))
    name))


(define (make-vector-constant vect)
  (let ((name (make-constant-name)))
    (set! *new-constant-list*
	  (cons (list 'set!
		      name
		      (list 'list->vector
			    (make-pair-constant-aux
				(vector->list vect) )))
		*new-constant-list*))
    name))


(define (make-pair-constant pair)
  (let ((name (make-constant-name)))
    (set! *new-constant-list*
	  (cons (list 'set!
		      name
		      (list 'cons
			    (make-pair-constant-aux (car pair))
			    (make-pair-constant-aux (cdr pair)) ))
		*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)) )
	  (set! *symbol-constant-table*
		(cons (list symb name) *symbol-constant-table*) )
	  (set! *symbol-list*
		(cons (list 'set!
			    name
			    `(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 (memq (car term) *higher-order-funs*)
		  (correct-ho-call
		     (cons (car term) (map ho-dot-pass new)) )
		  (cons (car term) (map ho-dot-pass new)) )))
	 ((memq (car term) *higher-order-funs*)
	     (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 *higher-order-flag*
	  (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*
				       (make-list (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 (make-list (cadr res))
				  (cddr res) )))))
      (if (null? res2)
	  (list res)
	  (list res
		(list 'define newname
		      (if (list? (cadr res2))
			  res2
			  (cons (car res2)
				(cons (make-list (cadr res2))
				      (cddr res2) ))))))))


(define (make-list args)
  (cond ((symbol? args)
	   (list args) )
	((null? args)
	   '() )
        (else (cons (car args) (make-list (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)) )
		  (list
		     (lift-statements
		       (push-result-var-in *return* (car (my-last-pair term)))
		       checkvars) )))
      ((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 '())) ))
      ((memq (car term) *current-formal-argslist*)
         (set! *higher-order-flag* #t)
	 (set! *higher-order-args*
	       (replaceq (car term) '#t *higher-order-args*) )
	 (cons *higher-order-call*
	       (map (lambda(x)(lift-stat-aux x checkvars)) term) ))
      (else
         (map (lambda(x)(lift-stat-aux x checkvars)) term) )))


;;; lift-if-arg? says whether it is needed/sensible to lift
;;; the if-statement with such a <term> as one of the resulting args

(define (lift-if-arg? term)
  (and (pair? term)
       (not (eq? 'quote (car term)))
       (not (and (memq
		    (car term)
		    (cons *not?*
			  (cons *and?*
				(cons *or?*
				     '(eq? = < > <= >=
				       number? boolean? null? pair? zero?
				       character? vector?)))))
		 (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))
		     (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))
		     (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)))
				 (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)
  (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)
  (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-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) )))))))

(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)) ))))

;===================================================================
;
;		       lambda-lifting
;
;==================================================================

;;; flatten-wholedef performs the first normalizing and lambda-lifting pass

(define (flatten-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) ))
;(pretty-print def)
    (set! def (lettify-lambdas def 100))
;(pretty-print def)
    (set! def (rename-vars def))
;(pretty-print def)
    (set! def (normalize def #f 1))
;(pretty-print def)
    (set! def (beautify-lets 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 (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)) )))))))

(define (lettify-lambdas term var-nr)
   (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))
			      (cddr term) ))))
	 ((and (pair? term)
	       (not (list? term)) )
	    (report-error
		   *current-fun-name* " has incorrect syntax.") )
	 ((memq (car term) '(let let* letrec))
	  (cons (car term)
                (list* (map (lambda(x)
			      (list (car x)
				    (lettify-lambdas (cadr x) var-nr)))
			   (cadr term) )
		       (lettify-lambdas (cddr term) var-nr) )))
	 ((some (lambda(x)(and (pair? x)(eq? 'lambda (car x)))) term)

           (let* ((lterm (some (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))))
                   ,(lettify-lambdas newterm (+ 1 var-nr)) )))
	 (else
            (map (lambda(x)(lettify-lambdas x var-nr)) 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
		      (some
			(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) (delete tmp groups)) ))
        ((begin (set! tmp
		      (some
			(lambda(in)
			  (and (is-path? (car input) in deps '())
			       (is-path? in (car input) deps '()) ))
			(cdr input)))
	    tmp)
	   (build-sconnected-groups deps (delete 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)
      (some (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)) )
          (set! *new-funs-list*
		(cons
                  (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) ))))
		  *new-funs-list*))
	   (set! new-names-args
		 (cons (list (car b) new-name freevars)
		       new-names-args))))
      fun-bindings)
   new-names-args)

(define (make-new-funs-letrec fun-bindings boundvars new-names-args lazy-flag)
  (let* ((fun-bodies (cons 'begin (map cadr fun-bindings)))
	 (intro-vars (introduced-free-vars fun-bodies new-names-args))
         (freevars (merge-free-vars intro-vars
				    (free-vars fun-bodies boundvars '()) ))
	 (new-names-args
	    (append
	      (map (lambda(b)
		      (list (car b) (make-new-funname) freevars) )
		   fun-bindings)
              new-names-args)))
    (for-each
      (lambda(b)
          (set! *new-funs-list*
		(cons
                  (list 'define
			(cadr (assq (car b) new-names-args))
                        (cons (caadr b)
			      (cons (make-arglist freevars (cadadr b))
				    (map (lambda(y)
					   (fetchify (cadr freevars)
					     (lambda-lift y
						 (union
						  (args->list (cadadr b))
						  boundvars)
						 new-names-args)))
                                         (cddadr b) ))))
		  *new-funs-list*)))
      fun-bindings)
   new-names-args))


(define (introduced-free-vars term names-args)
  (if (null? names-args)
      (list '() '())
      (introduced-free-vars-aux term names-args) ))

(define (introduced-free-vars-aux term names-args)
   (cond ((symbol? term)
	    (let ((tmp (assq term names-args)))
	      (if tmp (caddr tmp) '(()())) ))
	 ((not (pair? term)) '(()()))
	 ((eq? 'quote (car term)) '(()()))
	 (else
	    (merge-free-vars
	       (introduced-free-vars-aux (car term) names-args)
	       (introduced-free-vars-aux (cdr term) names-args) ))))


(define (new-fun-name a)
   (if (memq a *new-fun-names*)
       a
       (string->symbol
	  (string-append (symbol->string a)
			 *new-fun-infix*
			 (begin (set! *new-fun-nr* (+ 1 *new-fun-nr*))
				(number->string *new-fun-nr*) )))))


;-------------------------------------------------------------------
;
;		    free-vars collectors
;
;------------------------------------------------------------------


;;; all-free-vars takes a term and returns a list (a set) of all
;;; all free variables in term.

(define (all-free-vars term)
  (set! *free-vars-list* '())
  (all-free-aux! term '())
  *free-vars-list*)

(define (all-free-aux! term bound)
  (cond
     ((symbol? term)
        (if (and (not (memq term bound))
		 (not (memq term *free-vars-list*)) )
	    (set! *free-vars-list* (cons term *free-vars-list*)) ))
     ((not (pair? term)))
     ((eq? 'quote (car term)))
     ((eq? 'lambda (car term))
        (let ((new (union (args->list (cadr term)) bound)))
	  (for-each (lambda(x)(all-free-aux! x new)) (cddr term)) ))
     ((eq? 'let (car term))
        (let ((new (union (map car (cadr term)) bound)))
	  (for-each (lambda(x)(all-free-aux! (cadr x) bound)) (cadr term))
	  (for-each (lambda(x)(all-free-aux! x new)) (cddr term)) ))
     ((eq? 'let* (car term))
       (for-each (lambda(x)
		   (all-free-aux! (cadr x) bound)
		   (if (not (memq (car x) bound))
		       (set! bound (cons (car x) bound)) ))
		 (cadr term) )
       (for-each (lambda(x)(all-free-aux! x bound)) (cddr term)) )
     ((eq? 'letrec (car term))
        (set! bound (union (map car (cadr term)) bound))
	(for-each (lambda(x)(all-free-aux! (cadr x) bound)) (cadr term))
	(for-each (lambda(x)(all-free-aux! x bound)) (cddr term)) )
     ((eq? 'do (car term))
        (let ((new (union (map car (cadr term)) bound)))
	  (for-each (lambda(x)(all-free-aux! (cadr x) bound)) (cadr term))
	  (for-each (lambda(x)
		      (if (not (null? (cddr x)))
			  (all-free-aux! (caddr x) new) ))
		    (cadr term) )
	  (for-each (lambda(x)(all-free-aux! x new)) (caddr term))
	  (for-each (lambda(x)(all-free-aux! x new)) (cdddr term)) ))
     (else
        (for-each (lambda(x)(all-free-aux! x bound)) term) )))


;;; free-vars takes a term, a list of candidates for free vars (vars bound
;;; somewhere higher in the term) and a list of bound variables.
;;; The list of candidates is used in order not to consider the global
;;; variables (external function definitions, *vars*, etc) to be free.
;;; It returns a list of two disjoint sets: (<ordinary-free> <set!-free>),
;;; where <set!-free> is a list of free variables which have a set!
;;; applied to them somewhere in the term.
;;;	The differentiation is important, as ordinary (non-set!)
;;; free variables are passed as ordinary additional variables
;;; during lambda-lifting, whereas set!-variables have to be passed
;;; by reference and treated accordingly (fortunately this is simple
;;; in C: instead of x always write (*x)).


(define (free-vars term checkvars boundvars)
   (cond ((and (symbol? term) (memq term checkvars))
             (if (memq term boundvars)
                 '(()())
                 (list (list term) '()) ))
         ((not (pair? term)) '(()()) )
         ((eq? (car term) 'quote) '(()()) )
         ((eq? (car term) 'set!)
             (if (or (memq (cadr term) boundvars)
		     (not (memq (cadr term) checkvars)) )
                 (free-vars (caddr term) checkvars boundvars)
                 (merge-free-vars (list '() (list (cadr term)))
                              (free-vars (caddr term) checkvars boundvars) )))
         ((eq? (car term) 'lambda)
             (free-vars (cddr term)
			checkvars
			(append (args->list (cadr term))
                                boundvars )))
         ((memq (car term) '(let let* letrec))
             (free-vars (append (map cadr (cadr term))
                                (cddr term) )
			checkvars
                        (append (map car (cadr term))
                                boundvars )))
         ((eq? (car term) 'do)
             (free-vars (append (map cadr (cadr term))
                                (map (lambda(x)
                                       (if (null? (cddr x)) 1 (caddr x)) )
                                     (cadr term) )
                                (cddr term) )
			checkvars
                        (append (map car (cadr term))
                                boundvars )))
         (else
             (merge-free-vars (free-vars (car term) checkvars boundvars)
                              (free-vars (cdr term) checkvars boundvars) ))))

(define (merge-free-vars pair-a pair-b)
   (let* ((norm-a (car pair-a))
          (norm-b (car pair-b))
          (set-a  (cadr pair-a))
          (set-b  (cadr pair-b))
          (set-res (union set-a set-b)) )
      (list (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 ((not (pair? term))
	     term)
	((eq? 'quote (car term))
	     term)
	((and (eq? (car term) 'map)
	      (= 3 (length term))
	      (not *always-map->do-flag*) )
	    (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*) )
	    (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))))
	((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)
        ((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) '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? (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) ))
        ((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) )
       (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 lst) (else #f))
                       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)
					       #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) #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) )))

(define *comparison-fun-table*
 '((= num)(< num)(> num)(<= num)(>= num)
   (char=? chr)(char<? chr)(char>? chr)(char<=? chr)(char>=? chr)
   (char-ci=? chr)(char-ci<? chr)(char-ci>? chr)
                  (char-ci<=? chr)(char-ci>=? chr)
   (string=? str)(string<? str)(string>? str)(string<=? str)(string>=? str)
   (string-ci=? str)(string-ci<? str)(string-ci>? str)
                  (string-ci<=? str)(string-ci>=? str) ))

(define (make-new-var nr)
  (string->symbol (string-append *new-var-name* (number->string nr))) )


;==================================================================
;
;		  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) )
     ((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)) )))



;=============================================================
;
;		      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 (rename-vars term)
   (set! *var-nr* 0)
   (set! *free-vars-list* (all-free-vars term))
   (rename-vars-aux term '()) )


(define (rename-vars-aux term env)
  (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 ))))
    ((eq? 'let (car term))
         (let ((new-env (make-new-env (map car (cadr term)) env)))
            `(let
              ,(map (lambda(x)
                       (list (rename-vars-aux (car x) new-env)
                             (rename-vars-aux (cadr x) env) ))
                    (cadr term) )
              ,@(rename-vars-aux (cddr term) new-env) )))
    ((eq? 'do (car term))
         (let ((new-env (make-new-env (map car (cadr term)) env)))
            `(do
              ,(map (lambda(x)
                       (cons (rename-vars-aux (car x) new-env)
                             (cons (rename-vars-aux (cadr x) env)
                                   (rename-vars-aux (cddr x)
                                                    new-env ))))
                    (cadr term) )
              ,@(rename-vars-aux (cddr term) new-env) )))
    ((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) ))
               (set! old-env new-env)
               (set! new-env (make-new-env (list (caar part)) new-env))
               (set! new-args
                     (cons (list (rename-vars-aux (caar part) new-env)
                                 (rename-vars-aux (cadar part) old-env) )
                           new-args )))))
   ((eq? 'letrec (car term))
        (let ((new-env (make-new-env (map car (cadr term)) env)))
          `(letrec ,@(rename-vars-aux (cdr term) new-env)) ))
   ((list? term)
        (map (lambda(x)(rename-vars-aux x env)) term) )
   (else
        (cons (rename-vars-aux (car term) env)
              (rename-vars-aux (cdr term) env) ))))


(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)
  (append (map (lambda(x)
		 (if (or (memq x *new-fun-names*)
			 (and (not (assq x env))
			      (not (memq x *free-vars-list*)) ))
		     (cons x x)
		     (cons x
		       (string->symbol
                           (string-append
                              (symbol->string x)
                              *local-var-infix*
                              (begin (set! *var-nr* (+ 1 *var-nr*))
                                     (number->string *var-nr*) ))))))
	       vars)
          env ))

(define (make-new-env-lambda vars env)
  (append (map (lambda(x)
		 (if (assq x env)
                     (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)
       (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 (some (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)) (neq? (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)) )
       '() ))


;====================================================================
;
;	       auxiliary functions - a library
;
;===================================================================


(define (delete what lst)
  (cond ((null? lst) '())
	((eq? what (car lst)) (delete what (cdr lst)))
	(else (cons (car lst) (delete what (cdr lst)))) ))

(define (some f lst)
  (if (null? lst)
      #f
      (if (f (car lst)) (car lst) (some f (cdr lst))) ))

(define (member-if f lst)
   (if (null? lst)
       #f
       (if (f (car lst)) lst (member-if f (cdr lst))) ))

(define (filter f lst)
   (cond ((null? lst) '())
	 ((f (car lst))  (cons (car lst) (filter f (cdr lst))))
	 (else (filter f (cdr lst))) ))

(define list*
  (lambda x
     (cond ((null? x) '())
	   ((null? (cdr x)) (car x))
	   (else (cons (car x) (list*-aux (cdr x)))) )))

(define (list*-aux x)
    (cond ((null? x) '())
	   ((null? (cdr x)) (car x))
	   (else (cons (car x) (list*-aux (cdr x)))) ))

(define (neq? x y)
  (not (eq? x y)) )

(define (butlast lst)
  (if (null? lst)
      '()
      (let ((res '()))
	(do ((tmp lst (cdr tmp)))
	    ((null? (cdr tmp)) (reverse res))
	    (set! res (cons (car tmp) res)) ))))

(define  (union set-a set-b)
   (cond ((null? set-a) set-b)
         ((null? set-b) set-a)
         ((memq (car set-a) set-b)
             (union (cdr set-a) set-b) )
         (else
             (cons (car set-a)
                   (union (cdr set-a) set-b) ))))

(define (difference set-a set-b)
   (cond ((null? set-a) '())
         ((null? set-b) set-a)
         ((memq (car set-b) set-a)
             (difference (remove-one (car set-b) set-a)
                         (cdr set-b) ))
         (else
             (difference set-a (cdr set-b)) )))

(define (intersection set-a set-b)
  (cond	((null? set-b) '())
	((memq (car set-b) set-a)
           (cons (car set-b)
		 (intersection set-a (cdr set-b)) ))
	(else
	   (intersection set-a (cdr set-b)) )))

(define (remove-one what from)
   (cond ((null? from) from)
         ((eq? what (car from)) (cdr from))
         (else
            (cons (car from) (remove-one what (cdr from))) )))

(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)))) ))

(define (my-last-pair lst)
  (if (not (pair? lst))
      lst
      (my-last-pair-aux lst) ))

(define (my-last-pair-aux lst)
 (if (pair? (cdr lst))
      (my-last-pair-aux (cdr lst))
      lst))

(define (split lst)
  (let* ((half-n (quotient (length lst) 2))
	 (a (first-n-reverse half-n lst))
	 (b (nth-cdr half-n lst)) )
    (cons a b) ))

(define (first-n-reverse n lst)
  (if (zero? n) '() (cons (car lst) (first-n-reverse (- n 1) (cdr lst)))) )

(define (nth-cdr n lst)
  (if (zero? n) lst (nth-cdr (- n 1) (cdr lst))) )

(define (inside-term? x term)
  (cond ((eq? x term) #t)
	((pair? term)
	   (if (eq? 'quote (car term))
	       #f
	       (or (inside-term? x (car term))
		   (inside-term? x (cdr term)) )))
	(else #f) ))

(define (subst-term what for term)
  (cond ((eq? term for) what)
	((pair? term)
	   (if (eq? 'quote (car term))
	       term
	       (cons (subst-term what for (car term))
		     (subst-term what for (cdr term)) )))
	(else term) ))

(define (in-fun-position x term)
   (cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)
	 ((eq? x (car term)) #t)
	 (else (some (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)
	 ((memq (car term) lst) #t)
	 (else (some (lambda(y)(some-in-fun-position lst y)) term)) ))

;===========================  END ===============================



