
;;; the schant compiler (written in scheme) translates a scheme source
;;; program into schant virtual machine code. the specification of the
;;; machine is based on ideas from:
;;;   Functional Programming Application and Implementation
;;;     Peter Henderson 1980
;;;   Paradigms of Artificial Intelligence Programming
;;;     Peter Norvig 1992

(define (my-error x y)
  (display x)
  (display y)
  (newline)
  (exit 1))

(define (reverse-core x y)
  (cond
    ((null? x) y)
    (else
      (reverse-core
        (cdr x)
        (cons (car x) y)))))

(define (rev x)
  (reverse-core x '()))

(define (append2 x y)
  (cond
    ((null? x) y)
    (else
      (cons
        (car x)
        (append2 (cdr x) y)))))

(define label-count 0)

(define (gen-label)
  (set! label-count (+ label-count 1))
  (- label-count 1))

(define gensym-count 0)

(define (gensym)
  (let*
    ((prefix "g:::")
     (string-number (number->string gensym-count))
     (symbol (string->symbol (string-append prefix string-number))))
  (set! gensym-count (+ gensym-count 1))
  symbol))

(define (write-line line)
  (write line)
  (newline)
  line)

(define (display-line line)
  (display line)
  (newline)
  line)

(define (indent level)
  (if (> level 0)
    (begin
      (display "  ")
      (indent (- level 1)))))

(define (gen-instruction instruction)
  (list instruction))

(define (gen-opcode opcode)
  (list (gen-instruction opcode)))

(define (compile-nothing)
  '())

(define (val-more instruction val? more?)
  (if val?
    (if (not more?)
      (append2 instruction
        (compile-return))
      instruction)
    (compile-nothing)))

(define (compile-const const val? more?)
  (val-more
    (if (member const '(#t #f () 0 1 2))
      (gen-instruction
        (list const))
      (gen-instruction
        (list 'const const)))
    val? more?))

(define (compile-local var location val? more?)
  (val-more
    (gen-instruction
      (list 'lvar (car location) (cdr location) var))
    val? more?))

(define (compile-global var val? more?)
  (val-more
    (gen-instruction
      (list 'gvar var))
    val? more?))

(define (compile-var var location val? more?)
  (if (not (null? location))
    (compile-local var location val? more?)
    (compile-global var val? more?)))

(define (compile-local-set var location)
  (gen-instruction
    (list 'lset (car location) (cdr location) var)))

(define (compile-global-set var)
  (gen-instruction
    (list 'gset var)))

(define (compile-set! var location)
  (if (not (null? location))
    (compile-local-set var location)
    (compile-global-set var)))

(define (make-label label)
  (list '() label))

(define (compile-br label)
  (gen-instruction
    (cons 'br (make-label label))))

(define (compile-btr label)
  (gen-instruction
    (cons 'btr (make-label label))))

(define (compile-bfl label)
  (gen-instruction
    (cons 'bfl (make-label label))))

(define (compile-label label)
  (gen-instruction
    (list 'label label)))

(define (compile-pop)
  (gen-instruction
    (list 'pop)))

(define (compile-args args n)
  (cond
    ((null? args)
      (gen-instruction
        (list 'args n)))
    ((symbol? args)
      (gen-instruction
        (list 'argsd n)))
    ((and (pair? args) (symbol? (car args)))
      (compile-args (cdr args) (+ n 1)))
    (else
      (my-error "illegal argument list -- " args))))

(define (compile-return)
  (gen-instruction
    (list 'return)))

(define (compile-save label)
  (gen-instruction
    (cons 'save (make-label label))))

(define (compile-callj n)
  (gen-instruction
    (list 'callj n)))

(define (compile-callnj)
  (gen-instruction
    (list 'callnj)))

(define (compile-argl)
  (gen-instruction
    (list 'argl)))

(define (if-no-more-compile-return more?)
  (if (not more?)
    (compile-return)
    (compile-nothing)))

(define (if-no-val-compile-pop val?)
  (if (not val?)
    (compile-pop)
    (compile-nothing)))

(define (if-more-compile-br more? target)
  (if more?
    (compile-br target)
    (compile-nothing)))

(define (if-more-compile-label more? target)
  (if more?
    (compile-label target)
    (compile-nothing)))

(define (position x a n)
  (cond
    ((null? a) '())
    ((eq? x (car a)) n)
    (else
      (position x (cdr a) (+ n 1)))))
               
(define (variable-location2 var env x)
  (if (null? env)
    '()
    (let
      ((y (position var (car env) 0)))
      (if (number? y)
        (cons x y)
        (variable-location2 var (cdr env) (+ x 1))))))

(define (variable-location var env)
  (if (null? env)
    '()
    (variable-location2 var env 0)))

(define (primitive-procedure? proc n-args env)
  (if (not (null? (variable-location proc env))) ; primitive is shadowed
    #f
    (case proc
      ((display)
        (if (= n-args 1)
          '(display #t)
          '(displayfile #t)))
      ((write)
        (if (= n-args 1)
          '(write #t)
          '(writefile #t)))
      ((write-char)
        (if (= n-args 1)
          '(write-char #t)
          '(writecharfile #t)))
      ((newline)
        (if (= n-args 0)
          '(newline #t)
          '(newlinefile #t)))
      ((read-char)
        (if (= n-args 0)
          '(read-char #f)
          '(readcharfile #f)))
      ((open-input-file)
        (if (= n-args 1)
          '(open-input-file #f)
          '(open-binary-input-file #f)))
      ((open-output-file)
        (if (= n-args 1)
          '(open-output-file #f)
          '(open-binary-output-file #f)))
      ((make-vector)
        (if (= n-args 1)
          '(make-vector #f)
          '(make-vector-with-fill #f)))
      ((make-string)
        (if (= n-args 1)
          '(make-string #f)
          '(make-string-with-fill #f)))
      (else
        (assq proc
          '((car #f) (cdr #f) (caar #f) (cadr #f) (cdar #f) (cddr #f)
            (list-ref #f) (list-tail #f)
            (eqv? #f) (memq #f) (memv #f) (member #f) (assq #f) (assv #f)
            (cons #f) (not #f)
            (null? #f) (eq? #f) (symbol? #f) (pair? #f) (list? #f)
            (number? #f) (string? #f) (string-length #f)
            (string-ref #f) (string-set! #t) (string=? #f)
            (string<? #f) (string>? #f) (string<=? #f) (string>=? #f)
            (string-ci<? #f) (string-ci>? #f)
            (string-ci<=? #f) (string-ci>=? #f)
            (string-ci=? #f)
            (string->symbol #f) (symbol->string #f)
            (string->number #f) (number->string #f)
            (char? #f) (char=? #f) (char-alphabetic? #f) (char-numeric? #f)
            (char-upcase #f) (char-downcase #f)
            (char->integer #f) (integer->char #f)
            (integer? #f) (real? #f)
            (+ #f) (- #f) (* #f) (/ #f)
            (quotient #f) (remainder #f) (modulo #f)
            (floor #f) (ceiling #f) (truncate #f) (round #f)
            (bitwise-and #f) (bitwise-or #f) (bitwise-xor #f) (bitwise-not #f)
            (arithmetic-shift #f)
            (inexact->exact #f) (exact->inexact #f)
            (length #f)
            (= #f) (< #f) (> #f) (<= #f) (>= #f)
            (equal? #f)
            (set-car! #t) (set-cdr! #t)
            (vector? #f) (vector-length #f)
            (vector-ref #f) (vector-set! #t)
            (vector-fill! #t)
;           (make-hash-table #f) (hash-ref #f) (hash-set! #t)
            (boolean? #f)
            (procedure? #f)
            (eval #t) (apply #t)
            (write #t) (write-char #t) (newline #t)
            (read-char #f) (eof-object? #f)
            (read-binary #t) (write-binary #t)
	    (open-input-file #f) (open-output-file #f)
	    (close-input-port #f) (close-output-port #f)
            (save-binary #t)
            (system #t) (exit #t)
            ; extensions2
            ))))))

(define (primitive-has-side-effect? primitive-procedure)
  (eq? (cadr primitive-procedure) #t))

(define (no-val-and-no-side-effect? val? primitive-procedure)
  (if (not val?)
    (if (not (primitive-has-side-effect? primitive-procedure))
      #t
      #f)
    #f))
   
(define (self-evaluating? e)
  (cond
    ((null? e) #t)
    ((number? e) #t)
    ((string? e) #t)
    ((eq? e '#f) #t)
    ((eq? e '#t) #t)
    ((char? e) #t)
    (else #f)))

(define (quoted? e)
  (if (and (not (null? e)) (not (symbol? e)))
    (eq? (car e) 'quote)
    #f))

(define (text-of-quotation e)
  (cadr e))

(define (variable? e)
  (check-call/cc e)
  (log-library-procedure-call e)
  (symbol? e))

(define (assignment? e)
  (if (not (null? e))
    (eq? (car e) 'set!)
    #f))

(define (assignment-variable e)
  (cadr e))

(define (assignment-value e)
  (car (cddr e)))

(define (definition? e)
  (if (not (null? e))
    (eq? (car e) 'define)
    #f))

(define (lambda? e)
  (if (not (null? e))
    (eq? (car e) 'lambda)
    #f))

(define (conditional? e)
  (if (not (null? e))
    (eq? (car e) 'cond)
    #f))

(define (if? e)
  (if (not (null? e))
    (eq? (car e) 'if)
    #f))

(define (let? e)
  (if (not (null? e))
    (eq? (car e) 'let)
    #f))

(define (let*? e)
  (if (not (null? e))
    (eq? (car e) 'let*)
    #f))

(define (letrec? e)
  (if (not (null? e))
    (eq? (car e) 'letrec)
    #f))

(define (begin? e)
  (if (not (null? e))
    (eq? (car e) 'begin)
    #f))

(define (list-? e)
  (if (not (null? e))
    (eq? (car e) 'list)
    #f))

(define (arith-terms? e)
  (if (not (null? e))
    (and (memq (car e) '(+ - * /)) (not (= (length (cdr e)) 2)))
    #f))

(define (or? e)
  (if (not (null? e))
    (eq? (car e) 'or)
    #f))

(define (and? e)
  (if (not (null? e))
    (eq? (car e) 'and)
    #f))

(define (while? e)
  (if (not (null? e))
    (eq? (car e) 'while)
    #f))

(define (case? e)
  (if (not (null? e))
    (eq? (car e) 'case)
    #f))

(define (do? e)
  (if (not (null? e))
    (eq? (car e) 'do)
    #f))

(define (quasiquoted? e)
  (if (not (null? e))
    (eq? (car e) 'quasiquote)
    #f))

(define (string-? e)
  (if (not (null? e))
    (eq? (car e) 'string)
    #f))

(define (clauses e)
  (cdr e))

(define (no-clauses? clauses)
  (null? clauses))

(define (first-clause clauses)
  (car clauses))

(define (rest-clauses clauses)
  (cdr clauses))

(define (actions clause)
  (cdr clause))

(define (predicate clause)
  (if (pair? clause)
    (car clause)
    '()))

(define (else-clause? clause)
  (eq? (predicate clause) 'else))

(define (last-exp? seq)
  (null? (cdr seq)))

(define (application? e)
  (not (symbol? e)))

(define program-has-call/cc #f)

(define call/cc-code 
  (list (list
  (list 'proc
    (list
    (list 'args 1)
    (list 'cc)
    (list 'lvar 0 0 'f)
    (list 'callj 1)))
  (list 'gset 'call/cc)
  (list 'pop))))

(define library-procedures (list
  (list 'zero? #f
    '(define zero?
      (lambda (x) (= x 0)))
    '())
  (list 'positive? #f
    '(define positive?
      (lambda (x) (> x 0)))
    '())
  (list 'negative? #f
    '(define negative?
      (lambda (x) (< x 0)))
    '())
  (list 'abs #f
    '(define abs
      (lambda (x) (if (< x 0) (- x) x)))
    '())
  (list 'even? #f
    '(define (even? x)
       (= 0 (modulo x 2)))
    '())
  (list 'odd? #f
    '(define (odd? x)
       (= 1 (modulo x 2)))
    '())
  (list 'gcd #f
    '(define (gcd a b)
       (if (= b 0)
           (abs a)
           (gcd b (modulo a b))))
    '(abs))
  (list 'lcm #f
    '(define (lcm a b)
       (quotient (abs (* a b)) (gcd a b)))
    '(abs gcd))
  (list 'list #f
    '(define list
      (lambda x x))
    '())
  (list 'read #f
    '(define read
      (lambda args
        (letrec (
          (port
            (if (null? args)
              'stdin
              (car args)))
          (token-type '())
          (paren-level 0)
          (ch #\space)
          (previous-ch #\space)
          (TAB-CHAR (integer->char 9))
          (CARRIAGE-RETURN (integer->char 13))
          (white-space (list #\space #\newline TAB-CHAR CARRIAGE-RETURN))
          (readin
            (lambda ()
            (letrec (
              (my-list->vector 
                (lambda (l)
                  (let
                    ((size (length l)))
                    (let
                      ((v (make-vector size)))
                      (do ((i 0 (+ i 1))) ((= i size))
                        (vector-set! v i (car l))
                        (set! l (cdr l)))
                      v))))
              (get-token
                (lambda ()
                  (letrec (
                    (token '())
                    (token-list '())
                    (token-new '())
                    (token-tail '())
                    (char-alpha-numeric?
                      (lambda ()
                        (or (char-alphabetic? ch) (char-numeric? ch))))
                    (skip-past-alpha
                      (lambda ()
                        (let loop ()
                          (if (char-alpha-numeric?)
                            (begin
                              (get-ch)
                              (skip-past-alpha)
                              (loop))))))
                    (get-ch
                      (lambda ()
                        (if (not (eq? port 'stdin))
                          (set! ch (read-char port))
                          (set! ch (read-char)))
                        (if (char=? ch #\newline)
                          (set! ch #\space))))
                    (get-ch-no-newline
                      (lambda ()
                        (if (not (eq? port 'stdin))
                          (set! ch (read-char port))
                          (set! ch (read-char)))))
                    (skip-line
                      (lambda ()
                        (if (char=? ch #\newline)
                          (get-ch)
                          (begin
                            (get-ch-no-newline)
                            (skip-line)))))
                    (skip-blanks
                      (lambda ()
                        (cond
                          ((eof-object? ch))
                          ((char=? ch #\;)
                            (skip-line)
                            (skip-blanks))
                          ((memq ch white-space)
                            (get-ch)
                            (skip-blanks))
                          (else '()))))
                    (replace-last-ch
                      (lambda ()
                        (set-car! token-tail ch)
                        (set! previous-ch ch)
                        (get-ch)))
                    (append-to-list
                      (lambda ()
                        (set! token-new (list ch))
                        (if (not (null? token-list))
                          (begin
                            (set-cdr! token-tail token-new)
                            (set! token-tail (cdr token-tail)))
                          (begin
                            (set! token-list token-new)
                            (set! token-tail token-new)))
                        (set! previous-ch ch)
                        (get-ch)))
                    (get-vector
                      (lambda ()
                        (get-ch)
                        (if (member ch '(#\t #\f)) ; boolean true or false
                          (begin
                            (set! token-type 'BOOLEAN-TOK)
                            (if (char=? ch #\t)
                              (set! token #t)
                              (set! token #f))
                            (get-ch))
                          (if (char=? ch #\\)
                            (begin
                              (set! token-type 'CHAR-TOK)
                              (get-ch)
                              (set! token ch)
                              (let
                                ((first-ch ch))
                                (get-ch)
                                (case first-ch
                                  ((#\s)
                                    (if (char=? ch #\p)
                                      (begin
                                        (set! token #\space)
                                        (skip-past-alpha))))
                                  ((#\n)
                                    (if (char=? ch #\e)
                                      (begin
                                        (set! token #\newline)
                                        (skip-past-alpha)))))))
                            (set! token-type 'VECTOR-TOK)))))
                    (get-string
                      (lambda ()
                        (get-ch) ; after open double quote
                        (let loop ()
                          (if (not (or (char=? ch #\") (eof-object? ch)))
                            (begin
                              (append-to-list)
                              (if (char=? previous-ch #\\) ; escape char
                                (replace-last-ch))
                              (loop))))
                        (get-ch) ; after close double quote
                        (set! token-type 'STRING-TOK)
                        (set! token (list->string token-list))))
                    (append-e0!
                      (lambda (token)
                        (let
                          ((token-tail (list-tail token (- (length token) 1))))
                          (set-cdr! token-tail (list #\e #\0)))))
                    (number-token?
                      (lambda (token)
                        (letrec (
                          (ch #\space)
                          (END-OF-TOKEN (integer->char 0))
                          (return #f)
                          ; if we have a float number without an exponent
                          ; we will append "e0" to the token
                          (has-decimal #f)
                          (has-e #f)
                          (save-token token)
                          (next-ch
                            (lambda ()
                              (if (null? token)
                                (set! ch END-OF-TOKEN)
                                (begin
                                  (set! ch (car token))
                                  (if (char=? ch #\.)
                                    (set! has-decimal #t)
                                    (if (or (char=? ch #\e) (char=? ch #\E))
                                      (set! has-e #t)))
                                  (set! token (cdr token))))))
                          (state-0
                            (lambda ()
                              (next-ch)
                              (cond
                                ((char=? ch #\-) (state-1))
                                ((char-numeric? ch) (state-2))
                                ((char=? ch #\.) (state-3))
                                (else '()))))
                          (state-1
                            (lambda ()
                              (next-ch)
                              (cond
                                ((char=? ch #\.) (state-3))
                                ((char-numeric? ch) (state-2))
                                (else '()))))
                          (state-2
                            (lambda ()
                              (next-ch)
                              (cond
                                ((char=? ch #\.) (state-3))
                                ((char-numeric? ch) (state-2))
                                ((or (char=? ch #\e) (char=? ch #\E)) (state-4))
                                ((char=? ch END-OF-TOKEN) (state-7))
                                (else '()))))
                          (state-3
                            (lambda ()
                              (next-ch)
                              (cond
                                ((or (char=? ch #\e) (char=? ch #\E)) (state-4))
                                ((char-numeric? ch) (state-3))
                                ((char=? ch END-OF-TOKEN) (state-7))
                                (else '()))))
                          (state-4
                            (lambda ()
                              (next-ch)
                              (cond
                                ((or (char=? ch #\+) (char=? ch #\-)) (state-5))
                                ((char-numeric? ch) (state-6))
                                (else '()))))
                          (state-5
                            (lambda ()
                              (next-ch)
                              (if (char-numeric? ch) (state-6))))
                          (state-6
                            (lambda ()
                              (next-ch)
                              (cond
                                ((char=? ch END-OF-TOKEN) (state-7))
                                ((char-numeric? ch) (state-6))
                                (else '()))))
                          (state-7
                            (lambda ()
                              (if (and has-decimal (not has-e))
                                (append-e0! save-token))
                              (set! return #t))))
                          (state-0)
                          return)))
                    (get-symbol
                      (lambda ()
                        (let loop ()
                          (if (not (or (memq ch white-space)
                                       (memq ch '(#\( #\)))
                                       (eof-object? ch)))
                            (begin
                              (set! ch (char-downcase ch))
                              (append-to-list)
                              (loop))))
                        (if (equal? token-list '(#\.))
                          (set! token-type 'DOT-TOK)
                          (begin
                            (set! token-type 'SYMBOL-TOK)
                            (if (number-token? token-list) 
                              (set! token
                                (string->number (list->string token-list)))
                              (set! token
                                (string->symbol (list->string token-list)))))))))
                    (skip-blanks)
                    (if (eof-object? ch)
                      (begin
                        (set! token-type 'EOF-TOK)
                        (set! token ch))
                      (let
                        ((match (assv ch '(
                           (#\( OPAR-TOK) (#\) CPAR-TOK)
                           (#\' TIC-TOK) (#\, COMMA-TOK) (#\` BACKTIC-TOK)
			   (#\# VECTOR-TOK) (#\" STRING-TOK)))))
                        (if match
                          (case (cadr match)
                            ((OPAR-TOK CPAR-TOK TIC-TOK BACKTIC-TOK)
                              (set! token-type (cadr match))
                              (set! token ch)
                              (cond
                                ((eq? token-type 'OPAR-TOK)
                                  (set! paren-level (+ paren-level 1))
                                  (get-ch))
                                ((eq? token-type 'CPAR-TOK)
                                  (set! paren-level (- paren-level 1))
                                  (if (> paren-level 0)
                                    (get-ch)))
                                (else
                                  (get-ch))))
			    ((COMMA-TOK)
                              (set! token-type (cadr match))
                              (set! token ch)
                              (get-ch)
			      (if (char=? ch #\@)
				(begin
				  (set! token-type 'AT-TOK)
				  (set! token ch)
				  (get-ch))))
                            ((VECTOR-TOK)
                              (get-vector))
                            ((STRING-TOK)
                              (get-string)))
                          (get-symbol))))
; (display "get-token: ") (write token) (newline)
                    token)))
              (bad-sexpr
                (lambda (sexpr)
                  (error "bad sexpr" sexpr)))
              (read-dot-token
                (lambda ()
                  (let
                    ((token (get-token)))
                    (case token-type
                      ((OPAR-TOK)
                        (set! token (read-list))
                        (get-token) ; close paren
                        token)
                      ((TIC-TOK)
                        (set! token
		          (list (cons 'quote (list (readin)))))
                          token)
                      ((BACKTIC-TOK)
                        (set! token
		          (list (cons 'quasiquote (list (readin)))))
                          token)
                      ((COMMA-TOK)
                        (set! token
			  (list (cons 'unquote (list (readin)))))
                          token)
                      ((AT-TOK)
                        (set! token
			  (list (cons 'unquote-splicing (list (readin)))))
                          token)
                      (else
                        (if (not (or (eq? token-type 'SYMBOL-TOK)
                                     (eq? token-type 'STRING-TOK)))
                          (bad-sexpr token))
                        (get-token)
                        (if (not (eq? token-type 'CPAR-TOK))
                          (bad-sexpr "expecting close paren"))
                        token)))))
              (read-list
                (lambda ()
                  (let
                    ((lst '())
                     (tail '())
                     (new '()))
                    (let loop ((token (get-token)))
                      (if (not (eq? token-type 'CPAR-TOK))
                        (begin
                          (case token-type
                            ((OPAR-TOK)
                              (set! new (list (read-list))))
                            ((DOT-TOK)
                              (set-cdr! tail (read-dot-token))
                              (set! token-type 'WAS-DOT-TOK))
                            ((EOF-TOK)
                              (bad-sexpr "unexpected end of file"))
                            ((TIC-TOK)
                              (set!
				new (list (cons 'quote (list (readin))))))
                            ((BACKTIC-TOK)
                              (set!
				new (list (cons 'quasiquote (list (readin))))))
                            ((COMMA-TOK)
                              (set!
				new (list (cons 'unquote (list (readin))))))
                            ((AT-TOK)
                              (set!
				new
				(list
				  (cons 'unquote-splicing (list (readin))))))
                            ((VECTOR-TOK)
                              (set! new (list (read-vector))))
                            (else
                              (set! new (list token))))
                          (if (not (eq? token-type 'WAS-DOT-TOK))
                            (begin
                              (if (not (null? lst))
                                (begin
                                  (set-cdr! tail new)
                                  (set! tail (cdr tail)))
                                (begin
                                  (set! lst new)
                                  (set! tail new)))
                              (loop (get-token)))
                            (begin
                              (set! token-type 'CPAR-TOK))))))
                    lst)))
              (read-vector
                (lambda ()
                  (get-token)
                  (if (eq? token-type 'OPAR-TOK)
                    (my-list->vector (read-list))
                    (bad-sexpr "expecting open paren")))))
            (let
              ((token (get-token)))
              (case token-type
                ((OPAR-TOK)
                  (read-list))
                ((TIC-TOK)
                  (cons 'quote (list (readin))))
                ((BACKTIC-TOK)
		  (cons 'quasiquote (list (readin))))
                ((COMMA-TOK)
		  (cons 'unquote (list (readin))))
                ((AT-TOK)
		  (cons 'unquote-splicing (list (readin))))
                ((VECTOR-TOK)
                  (read-vector))
                ((CPAR-TOK)
                  (bad-sexpr "unexpected close paren"))
                (else
                  token)))))))
      (readin))))
    '(error list->string))
  (list 'error #f
    '(define (error reason . args)
      (display "Error: ")
      (display reason)
      (for-each
        (lambda (arg) 
          (display " ")
          (display arg))
        args)
      (newline)
      (exit 1))
    '(for-each))
  (list 'fold-right #f
    '(define (fold-right f init seq) 
      (if (null? seq) 
        init 
        (f (car seq) 
           (fold-right f init (cdr seq))))) 
    '())
  (list 'fold-left #f
    '(define (fold-left f init seq) 
      (if (null? seq) 
        init 
        (fold-left
          f
          (f init (car seq))
          (cdr seq))))
    '())
  (list 'reverse #f
    '(define (reverse x)
      (letrec (
        (rev
          (lambda (x y)
            (cond
              ((null? x) y)
              (else
                (rev
                  (cdr x)
                  (cons (car x) y)))))))
        (rev x '())))
    '())
  (list 'max #f
    '(define (max first . rest)
      (fold-left
        (lambda (x y)
          (if (> x y)
            x
            y))
        first
        rest))
    '(fold-left))
  (list 'min #f
    '(define (min first . rest)
      (fold-left
        (lambda (x y)
          (if (< x y)
            x
            y))
        first
        rest))
    '(fold-left))
  (list 'complex? #f
    '(define (complex? x)
       (number? x))
    '())
  (list 'rational? #f
    '(define (rational? x)
       (integer? x))
    '())
  (list 'exact? #f
    '(define (exact? x)
       (integer? x))
    '())
  (list 'inexact? #f
    '(define (inexact? x)
       (not (integer? x)))
    '())
  (list 'append #f
    '(define (append . lsts)
      (letrec (
        (append-two
          (lambda (list1 list2)
            (if (null? list1)
              list2
              (cons (car list1)
                    (append-two (cdr list1) list2)))))
        (improper-list?
          (lambda (l)
            (not (or (null? l) (pair? l)))))
        (fold-right-append
          (lambda (f init seq) 
            (cond
              ((null? seq) init) 
              ((null? (car seq)) (cadr seq)) 
              ((null? (cdr seq)) (append-two (car seq) (cdr seq)))  
              ((not (pair? (cdr seq)))
                (append-two (car seq) (cdr seq)))
              ((improper-list? (cdr (cadr seq))) ; seq ends in improper list
                (append-two (car seq) (cadr seq)))
              (else
                (f (car seq) 
                   (fold-right-append f init (cdr seq))))))))
        (cond
          ((null? lsts) '())
          ((null? (cdr lsts)) (car lsts))
          (else
            (fold-right-append
              (lambda (sublist acc)
                (append-two sublist acc))
              '()
              lsts)))))
    '())
  (list 'char-lower-case? #f
    '(define (char-lower-case? x)
      (let
        ((x (char->integer x)))
        (and (>= x 97) (<= x 122))))
    '())
  (list 'char-upper-case? #f
    '(define (char-upper-case? x)
      (let
        ((x (char->integer x)))
        (and (>= x 65) (<= x 90))))
    '())
  (list 'char-whitespace? #f
    '(define (char-whitespace? x)
      (let
        ((x (char->integer x)))
        (or (= x 32) (= x 10) (= x 9) (= x 13))))
    '())
  (list 'char<? #f
    '(define (char<? x y)
      (< (char->integer x) (char->integer y)))
    '())
  (list 'char>? #f
    '(define (char>? x y)
      (> (char->integer x) (char->integer y)))
    '())
  (list 'char<=? #f
    '(define (char<=? x y)
      (<= (char->integer x) (char->integer y)))
    '())
  (list 'char>=? #f
    '(define (char>=? x y)
      (>= (char->integer x) (char->integer y)))
    '())
  (list 'char-ci=? #f
    '(define (char-ci=? x y)
      (= (char->integer (char-upcase x)) (char->integer (char-upcase y))))
    '())
  (list 'char-ci<? #f
    '(define (char-ci<? x y)
      (< (char->integer (char-upcase x)) (char->integer (char-upcase y))))
    '())
  (list 'char-ci>? #f
    '(define (char-ci>? x y)
      (> (char->integer (char-upcase x)) (char->integer (char-upcase y))))
    '())
  (list 'char-ci<=? #f
    '(define (char-ci<=? x y)
      (<= (char->integer (char-upcase x)) (char->integer (char-upcase y))))
    '())
  (list 'char-ci>=? #f
    '(define (char-ci>=? x y)
      (>= (char->integer (char-upcase x)) (char->integer (char-upcase y))))
    '())
  (list 'assoc #f
    '(define (assoc thing alist)
      (if (null? alist)
        #f
        (if (equal? (car (car alist)) thing)
          (car alist)
          (assoc thing (cdr alist)))))
    '())
  (list 'list->vector #f
    '(define (list->vector l)
      (let
        ((size (length l)))
        (let
          ((v (make-vector size)))
          (do ((i 0 (+ i 1))) ((= i size))
            (vector-set! v i (car l))
            (set! l (cdr l)))
          v)))
    '())
  (list 'vector->list #f
    '(define (vector->list v)
      (let
        ((l '()))
        (do ((i 0 (+ i 1))) ((= i (vector-length v)))
          (set! l (cons (vector-ref v i) l)))
        (reverse l)))
    '(reverse))
  (list 'vector #f
    '(define (vector . x)
      (list->vector x))
    '(list->vector))
  (list 'string #f
    '(define (string . x)
      (list->string x))
    '(list->string))
  (list 'string-append #f
    '(define (string-append x y)
      (let
        ((z (make-string (+ (string-length x) (string-length y)))))
        (let loop ((index 0) (size (string-length x)))
          (if (< index size)
            (begin
              (string-set! z index (string-ref x index))
              (loop (+ index 1) size))))
        (let loop ((index 0) (size (string-length y)))
          (if (< index size)
            (begin
              (string-set! z (+ index (string-length x)) (string-ref y index))
              (loop (+ index 1) size))))
        z))
    '())
  (list 'list->string #f
    '(define (list->string charlist)
      (letrec
        ((len (length charlist))
         (newstr (make-string len))
         (fill-string!
           (lambda (str i len charlist)
             (if (= i len)
               str
               (begin (string-set! str i (car charlist))
                 (fill-string! str (+ i 1) len (cdr charlist)))))))
        (fill-string! newstr 0 len charlist)))
    '())
  (list 'string-fill! #f
    '(define (string-fill! s e)
      (let ((n (string-length s)))
        (let loop ((i 0))
          (if (= i n)
            s
            (begin (string-set! s i e) (loop (+ i 1)))))))
    '())
  (list 'string->list #f
    '(define (string->list s)
      (let loop ((n (- (string-length s) 1)) (l '()))
        (if (= n -1)
          l
          (loop (- n 1) (cons (string-ref s n) l)))))
    '())
  (list 'substring #f
    '(define (substring str start end)
      (if (not (string? str))
        (error 'substring "not a string"))
      (let*
        ((size (- end start))
         (sub-string (make-string size)))
        (do ((i 0 (+ i 1))) ((= i size))
          (string-set! sub-string i (string-ref str (+ start i))))
        sub-string))
    '(error))
  (list 'string-copy #f
    '(define (string-copy str)
      (if (not (string? str))
        (error 'string-copy "not a string"))
      (let*
        ((size (string-length str))
         (new-str (make-string size)))
        (do ((i 0 (+ i 1))) ((= i size))
          (string-set! new-str i (string-ref str i)))
        new-str))
    '(error))
  (list 'map #f
    '(define map
      (lambda aListOfArgs
        (let
          ((functor (car aListOfArgs))
           (listOfFunctorArgs (cdr aListOfArgs)) )
          (letrec (
            (error
              (lambda (x y)
                (display x)
                (display " ")
                (display y)
                (newline)
                (exit 1)))
            (map1
              (lambda (functor aList)
                (if (null? aList)
                  '()
                  (cons (functor (car aList))
                    (map1 functor (cdr aList))))))
            (mapN
              (lambda (functor aListOfLists)
                (if (null? (car aListOfLists))
                  '()
                  (let
                    ((aListOfCars (map1 car aListOfLists))
                     (aListOfCdrs (map1 cdr aListOfLists)))
                    (cons
                      (apply functor aListOfCars)
                      (mapN functor aListOfCdrs))))))
             (are-allTrue?
               (lambda (aListOfBooleans)
                 (if (null? aListOfBooleans)
                   #t
                   (if (car aListOfBooleans)
                     (are-allTrue? (cdr aListOfBooleans))
                     #f)))))
           (cond
             ((not (procedure? functor))
               (error 'map "first argument must be a procedure"))
             ((not
               (and
                 (are-allTrue? (map1 list? listOfFunctorArgs))
                 (let
                   ((listOfLengths
                    (map1 length listOfFunctorArgs)))
                   (are-allTrue?
                     (map1
                       (lambda (x) (equal? x (car listOfLengths)))
                       (cdr listOfLengths))))))
              (error
                'map
                "second and remaining arguments must be lists of equal length"))
             (else
               (mapN functor listOfFunctorArgs)))))))
    '(error))
  (list 'for-each #f
    '(define for-each
      (lambda (proc . lists)
        (letrec (
          (map-over-single-list
            (lambda (p l)
              (if (null? l)
                '()
                (cons
                  (p (car l)) 
                  (map-over-single-list p (cdr l)))))))
          (if (memq '() lists)
            '()
            (begin
	      (apply proc (map-over-single-list car lists))
	      (apply
                for-each 
                (cons proc (map-over-single-list cdr lists))))))))
    '())
  (list '__approximate #f
    '(define __approximate
      (lambda (a b term-coefficient x)
        (let
          ((d 0.0)
           (dd 0.0)
           (sv '())
           (y '())
           (y2 '()))

          (set! y (/ (- (- (* 2.0 x) a) b) (- b a)))
          (set! y2 (* 2.0 y)) 

          (do ((i (- (vector-length term-coefficient) 1) (- i 1))) ((= i 0))
            (set! sv d)
            (set! d (+ (- (* y2 d) dd) (vector-ref term-coefficient i)))
            (set! dd sv))

          (+ (- (* y d) dd) (* 0.5 (vector-ref term-coefficient 0))))))
    '())
  (list 'sqrt #f
    '(define sqrt
      (let
      ((sqrt-error (if (> 0.000000000001 0.0) 1.0e-10 ; precision 12
                                              1.0e-6))) ; precision 8
      (lambda (x)
        (let
          ((sqrt-tolerence sqrt-error))
          (if (= x 0.0)
            0.0
            (if (< x sqrt-tolerence)
              x
              (let
                ((temp (* x sqrt-tolerence))
                 (temp2 '())
                 (guess '())
                 (new-guess '())
                 (result '()))
                (set! sqrt-tolerence temp)
                (set! temp (* 0.5 x))
                (set! guess temp)
                (let loop ()
                  (set! temp (/ x guess))
                  (set! temp2 (+ guess temp))
                  (set! new-guess (* 0.5 temp2))
                  (set! result new-guess)
                  (set! temp (- guess new-guess))
                  (set! temp2 (abs temp))
                  (set! guess new-guess)
                  (if (> temp2 sqrt-tolerence)
                    (loop)))
                result)))))))
    '(abs))
  (list 'cos #f
    '(define cos
      (let
      ((precision-12? (if (> 0.000000000001 0.0) 1.0e-10 ; precision 12
                                                 1.0e-6))) ; precision 8
      (let*
        ((PI 3.14159265359e0)
         (TWOPI 6.28318530718e0)
         (PIOVERTWO 1.57079632679e0)
         (make-factorial-term
           (lambda (n)
	     (let
	       ((sum 1.0))
	       (do ((i 1 (+ i 1))) ((> i n))
	         (set! sum (* sum (/ 1.0 i)))) 
	       sum)))
         (factorial-terms
           (list->vector (list
             (make-factorial-term 1)
             (make-factorial-term 2)
             (make-factorial-term 3)
             (make-factorial-term 4)
             (make-factorial-term 5)
             (make-factorial-term 6)
             (make-factorial-term 7)
             (make-factorial-term 8)
             (make-factorial-term 9)
             (make-factorial-term 10)
             (make-factorial-term 11)
             (make-factorial-term 12)
             (make-factorial-term 13)
             (make-factorial-term 14)
             (make-factorial-term 15)
             (make-factorial-term 16)
             (make-factorial-term 17)
             (make-factorial-term 18))))
         (fmod
           (lambda (x y)
             (- x (* y (floor (/ x y))))))
         (cos-iterations
           (lambda (x)
	     (let
	       ((sum 1.0)
	        (temp 0.0)
	        (term 0.0)
	        (product (* x x))
	        (power 1.0)
	        (sign #t) ; negative
	        (i 1)
	        (N_TERMS
		  (if precision-12?
		    (if (< x 0.2) 4 8)
		    (if (< x 0.2) 3 4)))) ; precision 8
	        (set! power product)
	        (do ((iterations 0 (+ iterations 1))) ((= iterations N_TERMS))
	          (set! term (* power (vector-ref factorial-terms i)))
	          (set! power (* product power))
	          (if sign
		    (begin
		      (set! term (- term))
		      (set! sign #f))
		    (set! sign #t))
	          (set! sum (+ sum term))
	          (set! i (+ i 2)))
	        sum))))
        (lambda (x)
          (let
            ((y '())
             (quad '()))
            (set! x (fmod x TWOPI))
            (if (< x 0.0)
              (set! x (- x)))
            (set! quad (inexact->exact (floor (/ x PIOVERTWO))))
            (case quad
              ((0) ) ; quad 0 - no change to x
              ((1)
                (set! x (- PI x)))
              ((2)
                (set! x (- x PI)))
              (else
                (set! x (- TWOPI x))))
            (set! y (cos-iterations x))
            (if (or (= quad 1) (= quad 2))
              (set! y (- y)))
            y)))))
    '())
  (list 'sin #f
    '(define sin
      (let
        ((PIOVERTWO 1.57079632679e0))
        (lambda (x)
          (cos (- x PIOVERTWO)))))
    '(cos))
  (list 'tan #f
    '(define tan
      (let
        ((PI 3.14159265359e0)
         (TWOPI 6.28318530718e0)
         (PIOVERTWO 1.57079632679e0)
         (PIOVERFOUR 7.8539816339e-1)
         (THREEPIOVERTWO 4.71238898038e0)
         (tan-table (vector
           9.113043408310e-01
           4.894686436475e-01
           4.284834890964e-02
           1.024434335494e-02
           1.453268753834e-03
           2.787802534585e-04
           4.483018229357e-05
           7.992572703097e-06
           1.340847730798e-06
           2.331260749314e-07
           3.968754263447e-08
           6.840671173557e-09
           1.170503854690e-09
           2.011416987287e-10
           3.444903527207e-11
           5.744526426402e-12
         ))
         (fmod
           (lambda (x y)
             (- x (* y (floor (/ x y)))))))
        (lambda (x)
          (let
            ((octant '())
             (y '())
             (negate #f))
            (if (< x 0.0)
              (begin
                (set! x (- x))
                (set! negate #t)))
            (set! x (fmod x TWOPI))
            (set! octant (inexact->exact (floor (/ x PIOVERFOUR))))
            (case octant
              ((0) ) ; no change to x
              ((1)
                (set! x (- PIOVERTWO x)))
              ((2)
                (set! x (- x PIOVERTWO)))
              ((3)
                (set! x (- PI x)))
              ((4)
                (set! x (- x PI)))
              ((5)
                (set! x (- THREEPIOVERTWO x)))
              ((6)
                (set! x (- x THREEPIOVERTWO)))
              ((7)
                (set! x (- TWOPI x))))
            (set! y (__approximate 0.0 PIOVERFOUR tan-table x))
            (if (member octant '(1 2 5 6))
              (set! y (/ 1.0 y)))
            (if (member octant '(2 3 6 7))
              (set! y (- y)))
            (if negate
              (set! y (- y)))
            y))))
    '(vector __approximate))
  (list 'atan #f
    '(define atan
      (let
        ((PIOVERTWO 1.57079632679e0)
         (atan-table (vector
           8.541571727850e-01
           3.947364538712e-01
          -3.545533836906e-02
          -1.940941447856e-03
           1.095092531973e-03
          -1.026183743671e-04
          -1.896686898280e-05
           6.367123995572e-06
          -3.319258371985e-07
          -1.798601235057e-07
           4.156538239346e-08
           1.316371133191e-10
          -1.650416765872e-09
           2.684305423068e-10
           2.186429824761e-11
          -1.492593224175e-11
        )))
        (lambda (x)
          (if (< x 0.0)
            (begin
              (set! x (- x))
              (if (> x 1.0)
                (- (- PIOVERTWO (__approximate 0.0 1.0 atan-table (/ 1.0 x))))
                (- (__approximate 0.0 1.0 atan-table x))))
            (if (> x 1.0)
              (- PIOVERTWO (__approximate 0.0 1.0 atan-table (/ 1.0 x)))
              (__approximate 0.0 1.0 atan-table x))))))
    '(vector __approximate))
  (list 'acos #f
    '(define acos
      (lambda (x) ; -1 < x <= 1
        (* 2.0 (atan (/ (sqrt (- 1.0 (* x x))) (+ 1.0 x))))))
    '(sqrt atan))
  (list 'asin #f
    '(define asin
      (lambda (x) ; -1 < x <= 1
        (* 2.0 (atan (/ x (+ 1.0 (sqrt (- 1.0 (* x x)))))))))
    '(sqrt atan))
  (list 'exp #f
    '(define exp
      (let
        ((E 2.71828182846e0)
         (E2 7.38905609893e0)
         (E3 2.00855369232e1)
         (E4 5.45981500331e1)
         (exp-table (vector
           3.506775308754e0
           8.503916537808e-01
           1.052086936309e-01
           8.722104733316e-03
           5.434368311498e-04
           2.711543491302e-05
           1.128132888661e-06
           4.024558201513e-08
           1.256584355088e-09
           3.488149583989e-11
        )))
        (lambda (x)
          (letrec (
            (exponent 1.0)
            (split-exponent
              (lambda (n)
                (case n
                  ((0) )
                  ((1)
                    (set! exponent (* exponent E)))
                  ((2)
                    (set! exponent (* exponent E2)))
                  ((3)
                    (set! exponent (* exponent E3)))
                  ((4)
                    (set! exponent (* exponent E4)))
                  (else
                    (split-exponent (quotient n 2))
                    (split-exponent (+ (quotient n 2) (remainder n 2))))))))
            (let
              ((negative (< x 0.0)))
              (set! x (abs x))
              (let*
                ((k-real (floor x))
                 (k (inexact->exact k-real)) ; exponent
                 (z (- x k-real)) ; z is range reduction [0, 1]
                 (y (__approximate 0.0 1.0 exp-table z)))
                (split-exponent k)
                (set! y (* y exponent))
                (if negative
                  (/ 1.0 y)
                  y)))))))
    '(abs vector __approximate))
  (list 'log #f
    '(define log
      (let*
        ((N-LOG-TERMS 9)
         (odd-recipricals-table (make-vector N-LOG-TERMS))
         (LOGOFTEN 2.30258509299e0)
         (LOG-OF-ONE-FIFTH -1.60943791243e0)
         (LOG-OF-TWO-FIFTHS -9.1629073187e-1))
        (do ((i 0 (+ i 1))) ((= i N-LOG-TERMS)) ; initialize
          (vector-set! odd-recipricals-table i (/ 1.0 (+ (* i 2) 1))))
        (lambda (x)
          ; TODO make sure x > 0.0
          (letrec (
            (ln
              (lambda (x)
                ; converges for 0.5 < x
                (let*
                  ((z (/ (- x 1.0) (+ x 1.0)))
                   (power z)
                   (z^2 (* z z))
                   (term '())
                   (sum 0.0))
                  (do ((i 0 (+ i 1))) ((= i N-LOG-TERMS))
	            (set! term (* power (vector-ref odd-recipricals-table i))) 
                    (set! sum (+ sum term))
	            (set! power (* power z^2)))
                  (* sum 2.0))))
            (increase-power
              (lambda (n power)
                (if (< n 1.0)
                  (increase-power (* n 10.0) (- power 1))
                 ;(list (/ n 10.0) power)
                  (list n power))))
            (decrease-power
              (lambda (n power)
                (if (> 1.0 n)
                  (list n power)
                  (decrease-power (/ n 10.0) (+ power 1)))))
            (decode-float ; TODO make a primitive function
              (lambda (n)
                (let
                  ((sign (if (< n 0.0) -1.0 1.0))
                   (exponent 0)
                   (result '()))
                  (set! n (abs n))
                  (if (< n 1.0)
                    (set! result (increase-power n 0))
                    (set! result (decrease-power n 0)))
                  (vector (car result) (cadr result) sign)))))
            (let
              ((x2 (decode-float x)))
              (let
                ((significand (vector-ref x2 0))
                 (exponent (vector-ref x2 1)))
	        (let
	          ((power (* exponent LOGOFTEN)))
	          (if (< significand 0.3)
	            (begin
                      (+ power
	                 (+ LOG-OF-ONE-FIFTH (ln (* 5.0 significand)))))
	            (if (< significand 0.5)
	              (begin
                        (+ power
	                   (+ LOG-OF-TWO-FIFTHS (ln (* 2.5 significand)))))
                      (+ power
	                 (ln significand)))))))))))
    '(abs vector __approximate))
))

(define (log-library-dependencies dependencies)
  (if (not (null? dependencies))
    (let
      ((dependency (car dependencies)))
      (log-library-procedure-call dependency)
      (log-library-dependencies (cdr dependencies)))))

(define (log-library-procedure-call proc)
  (if (symbol? proc)
    (let
      ((library-procedure (assq proc library-procedures)))
      (if library-procedure
        (begin
          ; indicates a library procedure has a reference
          (set-car! (cdr library-procedure) #t)
          (log-library-dependencies (cadr (cddr library-procedure))))))))

(define (check-call/cc proc)
  (if (symbol? proc)
    (if (eq? proc 'call/cc)
      (set! program-has-call/cc #t))))

(define (operator app)
  (car app))

(define (operands app)
  (cdr app))

(define (internal-definition? e)
  (if (not (null? e))
    (if (pair? (car e))
      (definition? (car e))
      #f)
    #f))

(define (transform-internal-defines body)
  (if (null? body)
    '()
    (if (internal-definition? body)
      (cons
        (if (symbol? (car (cdr (car body))))
          (cdr (car body))
          (cons (caar (cdr (car body))) ; procedure name
            (list (list
              'lambda
              (cdar (cdar body)) ; arguments
              (append2 (list 'begin)
                       (cddr (car body))))))) ; procedure body
        (transform-internal-defines (cdr body)))
      '())))

(define (try-transform-internal-defines body)
  (if (internal-definition? body)
    (let*
      ((transformed (transform-internal-defines body)))
      (list (list
        'letrec
        transformed
        (append2 (list 'begin)
                 (list-tail body (length transformed))))))
    body))

(define (compile-procedure e env val? more? name)
  (if val?
    (append2
      (let
        ((args (cadr e))
         (body (try-transform-internal-defines (cddr e))))
        (gen-instruction
          (list
            'proc
            (append2
              (compile-lambda args body env)
              (list (list 'name name))))))
      (if-no-more-compile-return more?))
    (compile-nothing)))

(define (compound-procedure? code)
  (if (not (null? code))
    (eq? (car code) 'proc)
    #f))

(define (compile-assignment var val env val? more?)
  (let
    ((dummy
      (append2 (compile val env #t #t var)
        (compile-set!
          var
          (variable-location var env)))))
    (if (not more?)
      (append2 dummy
        (compile-return))
      (if (not val?)
        (append2 dummy
          (compile-pop))
        dummy))))

(define (definition-variable e)
  (if (variable? (cadr e))
    (cadr e)
    (car (cadr e))))

(define (definition-value e)
  (if (variable? (cadr e))
    (car (cddr e))
    (cons 'lambda
          (cons (cdr (cadr e))
                (cddr e)))))

(define (compile-definition e env val? more?)
  (append2
    (compile-assignment
      (definition-variable e)
      (definition-value e) env val? more?)
    (compile-pop)))

(define (compile-sequence e env val? more?)
  (cond
    ((null? e) (compile-const '() val? more?))
    ((last-exp? e) (compile (car e) env val? more? '()))
    (else
      (append2 (compile (car e) env #f #t '())
        (compile-sequence (cdr e) env val? more?)))))

(define (make-true-list dotted-list)
  (cond
    ((null? dotted-list) '())
    ((symbol? dotted-list) (list dotted-list))
    (else
      (cons (car dotted-list) (make-true-list (cdr dotted-list))))))

(define (compile-lambda args body env)
  (append2 (compile-args args 0)
    (compile-sequence body (cons (make-true-list args) env) #t #f)))

(define (transform-cond e)
  (if (null? e)
    '#f
    (if (else-clause? (first-clause e))
      (cons
        'begin
        (actions (first-clause e)))
      (cons
        'if
        (cons
          (predicate (first-clause e))
          (cons
            (cons
              'begin  
              (actions (first-clause e)))
            (cons
              (cons
                'cond
                (rest-clauses e))
              '())))))))

(define (compile-cond e env val? more?)
  (compile (transform-cond e) env val? more? '()))

(define (negative-predicate? predicate)
  (if (pair? predicate)
    (eq? (car predicate) 'not)
    #f))
       
(define (compile-if predicate then else_ env val? more?)
  (cond
    ((eq? predicate '#f)
      (if (not (null? else_))
        (compile (car else_) env val? more? '())))
    ((self-evaluating? predicate) ; true predicate
      (compile then env val? more? '()))
    ((and (negative-predicate? predicate) (not (null? else_)))
      (compile-if (cadr predicate) (car else_) (list then) env val? more?))
    (else
      (begin
        (if (null? else_) ; no else
          (set! else_ '(()))) ; if there isnt an else make it be '()
        (let
          ((compile-predicate (compile predicate env #t #t '()))
           (compile-then (compile then env val? more? '()))
           (compile-else (compile (car else_) env val? more? '())))
          (cond
            ((equal? compile-then compile-else)
              (append2 (compile predicate env #f #t '())
                compile-else))
            (else
              (let
                ((target1 (gen-label))
                 (target2 (gen-label)))
                (append2 compile-predicate
                  (append2 (compile-bfl target1)
                    (append2 compile-then
                      (append2 (if-more-compile-br more? target2)
                        (append2 (compile-label target1)
                          (append2 compile-else
                            (if-more-compile-label more? target2)))))))))))))))

(define (build-let-formals pairs)
  (if (null? pairs)
    '()
    (cons
      (caar pairs)
      (build-let-formals (cdr pairs)))))

(define (build-let-actuals pairs)
  (if (null? pairs)
    '()
    (cons
      (car (cdar pairs))
      (build-let-actuals (cdr pairs)))))

(define (transform-let formals body actuals)
  (cons
    (cons
      'lambda
      (cons formals body))
    actuals))

(define (transform-let-tag tag formals body actuals)
  (cons
    (list
      'letrec
      (cons
        (cons
          tag
          (cons
            (cons
              'lambda
              (cons formals body))
            '()))
         '())
      tag)
    actuals))

(define (compile-let e env val? more?)
  (if (symbol? (car e))
    (let
      ((tag (car e))
       (formals (build-let-formals (cadr e)))
       (body (try-transform-internal-defines (cddr e)))
       (actuals (build-let-actuals (cadr e))))
      (compile (transform-let-tag tag formals body actuals) env val? more? '()))
    (let
      ((formals (build-let-formals (car e)))
       (body (try-transform-internal-defines (cdr e)))
       (actuals (build-let-actuals (car e))))
      (compile (transform-let formals body actuals) env val? more? '()))))

(define (transform-let* assignments body)
  (if (not (null? assignments))
    (cons
      'let
      (cons
        (list
          (car assignments))
        (list
          (cons
            'let*
            (cons
              (cdr assignments)
              body)))))
    (cons ; degenerate let*
      (cons
        'lambda
        (cons
          '()
          body))
      '())))

(define (compile-let* e env val? more?)
  (let
    ((assignments (car e))
     (body (try-transform-internal-defines (cdr e))))
    (compile (transform-let* assignments body) env val? more? '())))

(define (build-letrec-unassigned pairs)
  (if (null? pairs)
    '()
    (cons
      (cons
        (caar pairs)
        (cons '() '()))
      (build-letrec-unassigned (cdr pairs)))))

(define (build-letrec-assigned pairs body)
  (if (null? pairs)
    body
    (cons
      (cons
        'set!
        (car pairs))
      (build-letrec-assigned (cdr pairs) body))))

(define (transform-letrec unassigned assigned)
  (cons
    'let
    (cons
      unassigned
      assigned)))

(define (compile-letrec e env val? more?)
  (let
    ((unassigned (build-letrec-unassigned (car e)))
     (assigned (build-letrec-assigned
                 (car e)
                 (try-transform-internal-defines (cdr e)))))
    (compile (transform-letrec unassigned assigned) env val? more? '())))

(define (compile-list-of-values e env)
  (if (null? e)
    '()
    (append2 (compile (car e) env #t #t '())
      (compile-list-of-values (cdr e) env))))

(define (transform-list e)
  (if (null? e)
    '()
    (cons
      'cons
      (cons
        (car e)
        (cons
          (cons
            'list
            (cdr e))
          '())))))

(define (compile-list e env val? more?)
  (compile (transform-list e) env val? more? '()))

(define (transform-arith-terms f e)
  (if (= (length e) 2)
    (cons f (rev e))
    (list f (transform-arith-terms f (cdr e)) (car e))))

(define (arith-term-constant f)
  (cadr (assq f '((+ 0) (- 0) (* 1) (/ 1)))))

(define (prepare-arith-terms f e)
  (if (= (length e) 1)
    (rev (cons (arith-term-constant f) e))
    (rev e)))

(define (compile-arith-terms f e env val? more?)
  (if (= (length e) 0)
    (compile (arith-term-constant f) env val? more? '())
    (compile
      (transform-arith-terms f (prepare-arith-terms f e))
      env val? more? '())))

(define (transform-or e)
  (if (null? e)
    '#f
    (if (null? (cdr e))
      (car e)
      (let
        ((x (gensym)))
        (cons
          'let
           (cons
             (cons
               (cons
                 x
                 (cons
                   (car e)
                   '()))
               '())
             (cons
               (cons
                 'if
                 (cons
                   x
                   (cons
                     x
                     (cons
                       (cons
                         'or
                         (cdr e))
                       '()))))
               '())))))))

(define (compile-or e env val? more?)
  (compile (transform-or e) env val? more? '()))

(define (transform-and e)
  (if (null? e)
    '#t
    (if (null? (cdr e))
      (car e)
      (cons
        'if
        (cons
          (car e)
          (cons
            (cons
              'and
              (cdr e))
            (cons
              '#f
              '())))))))

(define (compile-and e env val? more?)
  (compile (transform-and e) env val? more? '()))

(define (transform-while test body)
  (let
    ((loop (gensym)))
    (cons
      'letrec
      (cons
        (cons
          (cons
            loop
            (cons
              (cons
                'lambda
                (cons
                  '()
                  (cons
                    (cons
                      'if
                      (cons
                        test
                        (cons
                          (cons
                            'begin
                            (append2
                              body
                              (cons
                                (cons loop '())
                                '())))
                          '())))
                    '())))
              '()))
          '())
        (list
          (list loop))))))

(define (compile-while e env val? more?)
  (let
    ((test (car e))
     (body (cdr e)))
    (compile (transform-while test body) env val? more? '())))

(define (transform-one-case key-name one-case)
  (if (eq? (car one-case) 'else)
    one-case
    (let
      ((selectors (car one-case)))
      (if (= (length selectors) 1)
        (cons
          (cons
            'eqv?
            (cons
              key-name
              (cons
                (cons
                  'quote
                  (cons
                    (car selectors)
                    '()))
                '())))
          (cdr one-case))
        (cons
          (cons
            'memv
            (cons
              key-name
              (cons
                (cons
                  'quote
                  (cons
                    selectors
                    '()))
                '())))
          (cdr one-case))))))

(define (transform-rest-of-case key-name rest-of-case)
  (if (null? rest-of-case)
    '()
    (cons
      (transform-one-case key-name (car rest-of-case))
      (transform-rest-of-case key-name (cdr rest-of-case)))))
       
(define (transform-case key-value body)
  (let
    ((key-name (gensym)))
    (cons 'let
      (cons
        (cons
          (cons
            key-name
            (cons key-value '()))
          '())
        (cons
          (cons
            'cond
            (transform-rest-of-case key-name body))
          '())))))

(define (compile-case e env val? more?)
  (let
    ((key-value (car e))
     (body (cdr e)))
    (compile (transform-case key-value body) env val? more? '())))

(define (transform-do vars inits steps test exprs commands)
  (list
    'letrec
    (list
      (list
        'loop
        (list
          'lambda
           vars
           (list
             'if
             test
             (append2
               (list 'begin)
               exprs)
             (append2
               (list 'begin)
               (append2
                 commands
                 (list
                   (append2
                     (list 'loop)
                     steps))))))))
      (append2
        (list 'loop)
        inits)))

(define (build-do-vars e)
  (if (null? e)
    '()
    (cons (caar e) (build-do-vars (cdr e)))))

(define (build-do-inits e)
  (if (null? e)
    '()
    (cons (cadr (car e)) (build-do-inits (cdr e)))))

(define (build-do-step-value e)
  (if (null? (cddr (car e)))
    (caar e) ; use var if no step value
    (car (cddr (car e)))))

(define (build-do-steps e)
  (if (null? e)
    '()
    (cons (build-do-step-value e) (build-do-steps (cdr e)))))

(define (compile-do e env val? more?)
  (let
    ((vars (build-do-vars (car e)))
     (inits (build-do-inits (car e)))
     (steps (build-do-steps (car e)))
     (test (caar (cdr e)))
     (exprs (cdar (cdr e)))
     (commands (cdr (cdr e))))
    (compile
      (transform-do vars inits steps test exprs commands) env val? more? '())))

(define (expand-quasiquote x nesting)
  ; expand a quasiquote form into append, list, and cons calls
  (letrec (
    (my-eval ; do nothing
      (lambda (x) x))
    (starts-with
      (lambda (x y)
        (eq? (car x) y)))
    (constant?
      (lambda (exp)
        (and (not (pair? exp))
          (not (symbol? exp)))))
    (combine-quasiquote
      (lambda (left right x)
        ; combine left and right (car and cdr), possibly re-using x
        (cond
          ((and (constant? left) (constant? right))
           (if (and (eqv? (my-eval left) (car x))
                    (eqv? (my-eval right) (cdr x)))
             (list 'quote x)
             (list 'quote (cons (my-eval left) (my-eval right)))))
          ((null? right)
           (list 'list left))
          (else
            (list 'cons left right)))))
    )
    (cond
      ((vector? x)
       (list 'apply 'vector (expand-quasiquote (vector->list x) nesting)))
      ((not (pair? x))
       (if (symbol? x)
         (list 'quote x)
         x))
      ((and (starts-with x 'unquote)
	    (= (length x) 2))      
        (if (= nesting 0)
          (cadr x)
	  (combine-quasiquote
            ''unquote 
	    (expand-quasiquote (cdr x) (- nesting 1))
	    x)))
      ((and (starts-with x 'quasiquote)
	    (= (length x) 2))      
        (combine-quasiquote
          ''quasiquote 
	  (expand-quasiquote (cdr x) (+ nesting 1))
          x))
      ((and (pair? (car x))
	    (eq? (caar x) 'unquote-splicing)
            (= (length (car x)) 2))      
        (if (= nesting 0)
          (list
	    'append
	    (cadr (car x))
	    (expand-quasiquote (cdr x) nesting))
          (combine-quasiquote
	    (expand-quasiquote (car x) (- nesting 1))
            (expand-quasiquote (cdr x) nesting)
            x)))
      (else
        (combine-quasiquote
	  (expand-quasiquote (car x) nesting)
          (expand-quasiquote (cdr x) nesting)
          x)))))

(define (string-append-core x y)
  (let
    ((z (make-string (+ (string-length x) (string-length y)))))
    (let loop ((index 0) (size (string-length x)))
      (if (< index size)
        (begin
          (string-set! z index (string-ref x index))
          (loop (+ index 1) size))))
    (let loop ((index 0) (size (string-length y)))
      (if (< index size)
        (begin
          (string-set! z (+ index (string-length x)) (string-ref y index))
          (loop (+ index 1) size))))
    z))

(define (n-arguments str n)
  (if (= n 0)
    '()
    (cons
      (string->symbol (string-append-core str (number->string n)))
      (n-arguments str (- n 1)))))

(define (n-parameters primitive)
  (cadr
    (assq primitive
      '((car 1) (cdr 1) (caar 1) (cadr 1) (cdar 1) (cddr 1)
        (list-ref 2) (list-tail 2)
        (eqv? 2) (memq 2) (memv 2) (member 2) (assq 2) (assv 2)
        (cons 2) (not 1)
        (null? 1) (eq? 2) (symbol? 1) (pair? 1) (list? 1)
        (number? 1) (string? 1) (make-string 1) (string-length 1)
        (string-ref 2) (string-set! 3) (string=? 2)
        (string<? 2) (string>? 2) (string<=? 2) (string>=? 2)
        (string-ci<? 2) (string-ci>? 2)
        (string-ci<=? 2) (string-ci>=? 2)
        (string-ci=? 2)
        (string->symbol 1) (symbol->string 1)
        (string->number 1) (number->string 1)
        (char? 1) (char=? 2) (char-alphabetic? 1) (char-numeric? 1)
        (char-upcase 1) (char-downcase 1)
        (char->integer 1) (integer->char 1)
        (integer? 1) (real? 1)
        (+ 2) (- 2) (* 2) (/ 2)
        (quotient 2) (remainder 2) (modulo 2)
        (floor 1) (ceiling 1) (truncate 1) (round 1)
        (bitwise-and 2) (bitwise-or 2) (bitwise-xor 2) (bitwise-not 1)
        (arithmetic-shift 2)
        (inexact->exact 1) (exact->inexact 1)
        (length 1)
        (= 2) (< 2) (> 2) (<= 2) (>= 2)
        (equal? 2)
        (set-car! 2) (set-cdr! 2)
        (vector? 1) (make-vector 1) (vector-length 1)
        (vector-ref 2) (vector-set! 3)
        (vector-fill! 2)
        (boolean? 1)
        (procedure? 1)
        (eval 1) (apply 2)
        (write 1) (write-char 1) (newline 0)
        (read-char 0) (eof-object? 1)
        (read-binary 2) (write-binary 2)
        (open-input-file 1) (open-output-file 1)
        (close-input-port 1) (close-output-port 1)
	(exit 1)
        ; extensions1
        (save-binary 1)
        (system 1)
;       (make-hash-table 1) (hash-ref 2) (hash-set! 3)
        ))))

(define (procedure-has-no-args? procedure args)
  (if (pair? procedure)
    (if (eq? (car procedure) 'lambda)
      (if (null? (cadr procedure))
        #t ; report error if no args TODO
        #f)
      #f)
    #f))

(define (compile-apply-apply args env val? more?)
  (let
    ((procedure (car args))
     (arguments (cadr args))
     (k (gen-label)))
    (append2 (compile-save k)
      (append2 (compile arguments env #t #t '())
        (append2 (compile-argl)
          (append2 (compile procedure env #t #t '())
            (append2 (compile-callnj)
              (append2 (compile-label k)
                (append2
                  (if-no-val-compile-pop val?)
                  (if-no-more-compile-return more?))))))))))

(define (compile-apply-eval args env val? more?)
  (let
    ((m (gen-label))
     (n (gen-label)))
    (append2 (compile-save m)
      (append2 (compile-save n)
        (append2 (compile-list-of-values args env)
          (append2 (gen-instruction (list 'gvar 'eval))
            (append2 (compile-callj 1)
              (append2 (compile-label n)
                (append2 (gen-instruction (list 'assemble ))
                  (append2 (gen-instruction (list 'const '()))
                    (append2 (gen-instruction (list 'cons))
                      (append2 (gen-instruction (list 'makeproc))
                        (append2 (compile-callj 0)
                          (append2 (compile-label m)
                            (append2
                              (if-no-val-compile-pop val?)
                              (if-no-more-compile-return more?))))))))))))))))

(define primitive-procedure-references '())

(define (log-primitive-procedure-reference p)
  (if (not (assq p primitive-procedure-references))
    (set! primitive-procedure-references 
      (append2
        primitive-procedure-references
        (list (list p (length primitive-procedure-references))))))) 

(define (compile-primitive-procedure-reference e env val? more?)
  (compile
    (list
      'vector-ref
      '__primitives
      (cadr (assq e primitive-procedure-references)))
    env val? more? '()))

(define (build-primitive-reference primitive n-args n)
  (letrec (
    (build-n-arguments
      (lambda (n)
        (case n
          ((0) '())
          ((1) '(n1))
          ((2) '(n1 n2))
          ((3) '(n1 n2 n3))))))
    (list
      'vector-set!
      '__primitives
      n
      (list
        'lambda
        (build-n-arguments n-args)
        (cons
          primitive
          (build-n-arguments n-args)))
      )))

(define (build-primitive-references primitive-procedure-references n)
  (if (null? primitive-procedure-references)
    '()
    (cons
      (build-primitive-reference
        (caar primitive-procedure-references)
        (n-parameters (caar primitive-procedure-references))
        n)
      (build-primitive-references
        (cdr primitive-procedure-references)
        (+ n 1)))))



(define (compile e env val? more? name)
; (display "* ")
; (display e)
; (newline)
  (cond
    ((self-evaluating? e) (compile-const e val? more?))
    ((quoted? e) (compile-const (text-of-quotation e) val? more?))
    ((and (symbol? e) 
          (primitive-procedure? e 0 env))
      (log-primitive-procedure-reference e)
      (compile-primitive-procedure-reference e env val? more?))
    ((variable? e) (compile-var e (variable-location e env) val? more?))
    ((definition? e) (compile-definition e env val? more?))
    ((assignment? e)
      (compile-assignment
        (assignment-variable e)
        (assignment-value e) env val? more?))
    ((lambda? e) (compile-procedure e env val? more? name))
    ((conditional? e) (compile-cond (clauses e) env val? more?))
    ((if? e)
      (compile-if
        (cadr e) (car (cddr e)) (cdr (cddr e))
        env val? more?))
    ((let? e) (compile-let (cdr e) env val? more?))
    ((let*? e) (compile-let* (cdr e) env val? more?))
    ((letrec? e) (compile-letrec (cdr e) env val? more?))
    ((begin? e) (compile-sequence (cdr e) env val? more?))
    ((list-? e) (compile-list (cdr e) env val? more?))
    ((arith-terms? e) (compile-arith-terms (car e) (cdr e) env val? more?))
    ((or? e) (compile-or (cdr e) env val? more?))
    ((and? e) (compile-and (cdr e) env val? more?))
    ((while? e) (compile-while (cdr e) env val? more?))
    ((case? e) (compile-case (cdr e) env val? more?))
    ((do? e) (compile-do (cdr e) env val? more?))
    ((quasiquoted? e)
      (compile
        (expand-quasiquote
	  (cadr e)
	  0)
        env val? more? name))
    ((application? e)
      (compile-apply
        (operator e)
        (operands e)
        env val? more?))
    (else
      (my-error "unknown expression type -- " e))))

(define (compile-apply procedure args env val? more?)
  (let
    ((primitive-procedure (primitive-procedure? procedure (length args) env)))
    (if primitive-procedure
      (if (no-val-and-no-side-effect? val? primitive-procedure)
        (compile-sequence args env #f more?)
        (if (eq? (car primitive-procedure) 'apply)
          (compile-apply-apply args env val? more?)
          (if (eq? (car primitive-procedure) 'eval)
            (compile-apply-eval args env val? more?)
            (append2 (compile-list-of-values args env)
              (append2 (gen-opcode (car primitive-procedure))
                (append2
                  (if-no-val-compile-pop val?)
                  (if-no-more-compile-return more?)))))))
      (if (procedure-has-no-args? procedure args)
        (compile-sequence (cddr procedure) env val? more?)
        (if more?
          (let
            ((k (gen-label)))
            (append2 (compile-save k)
              (append2 (compile-list-of-values args env)
                (append2 (compile procedure env #t #t '())
                  (append2 (compile-callj (length args))
                    (append2 (compile-label k)
                      (if-no-val-compile-pop val?)))))))
          (append2 (compile-list-of-values args env)
            (append2 (compile procedure env #t #t '())
              (compile-callj (length args)))))))))
   
(define (label? instruction)
  (if (not (null? instruction))
    (eq? (car instruction) 'label)
    #f))

(define (proc-code code)
  (cadr code))

(define (print-instruction instruction level)
  (indent level)
  (cond
    ((label? instruction)
      (display-line (cadr instruction)))
    ((compound-procedure? instruction)
      (display-line "(proc")
      (print-code (proc-code instruction) (+ level 1))
      (indent level)
      (display-line ")"))
    (else
      (write-line instruction))))

(define (print-code code level)
  (if (not (null? code))
    (begin
      (print-instruction (car code) level)
      (print-code (cdr code) level))))

(define (display-code code)
  (if (not (null? code))
    (begin
      (print-code (car code) 0)
      (display-code (cdr code)))))

(define (compile-scheme)
  (let
    ((e (read)))
    (if (eof-object? e)
      '()
      (cons
        (compile
          e
          '() ; environment
          #t #t '())
        (compile-scheme)))))

(define (get-library-procedures library-procedures)
  (if (null? library-procedures)
    '()
    (if (car (cdar library-procedures))
      (cons (car (cdr (cdar library-procedures)))
        (get-library-procedures (cdr library-procedures)))
      (get-library-procedures (cdr library-procedures)))))

(define (compile-library-procedures library-procedures)
  (if (null? library-procedures)
    '()
    (cons
      (compile
        (car library-procedures)
        '() ; environment
        #t #t '()) 
      (compile-library-procedures (cdr library-procedures)))))

(define top-level (compile-scheme))

(display-line "(")
(if program-has-call/cc
  (display-code call/cc-code))
(let
  ((library-procedures-code
    (compile-library-procedures (get-library-procedures library-procedures))))
  (if (not (null? primitive-procedure-references))
    (let
      ((list-of-primitive-procs
        (build-primitive-references primitive-procedure-references 0)))
      (display-code (list
        (compile
          (list
            'define
            '__primitives
            (list
              'make-vector
              (length list-of-primitive-procs)))
          '() ; environment
          #t #t '())))
      (display-code (list
        (compile
          (cons 'begin list-of-primitive-procs)
          '() ; environment
          #t #t '())))))
  (display-code library-procedures-code)
  (display-code top-level))
(display-line "(halt)")
(display-line ")")
