;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 6.821 Problem Set #4
;;;
;;;
;;; FLEX and FLAT interpreters:
;;; FLEX = (CBV FL) - recursion
;;; FLAT = (CBV FL) - recursion - (free vars in procedures) + tuples
;;;
;;; In both languages, all primitive operators are accessed as 
;;; primops, e.g., (primop + ...), (primop left ...), etc.
;;;
;;; Author: Brian
;;; Created: 10/1/94
;;; Adapted from Lyn's ps4.fx (1992) and fl-naming.scm (1994)
;;; Revisions:
;;;	10/4: Fixed left and right primops.
;;;	10/7: Changed parse-common to use parse in all cases.
;;;	10/11: Added symbol to keyword list.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; PROBLEM SET CODE begins with DATATYPES: 
;;;	ignore the initial patching for #u


;;;----------------------------------------------------------------------------
;;; Magic for handling unit.  This should really be in a separate file, or
;;; be part of Scheme+.

(define-structure (unit-obj (print-procedure 
			     (lambda (state struct) 
			       (unparse-string state "#u")))))

;; THE-UNIT is the unique instance of the UNIT-OBJ structure
(define the-unit (make-unit-obj))

(define (unit? obj) (eq? obj the-unit))

;;; Changing parser to handle #u
(define parse-object/unit
  (let ((discard-char (access discard-char 
			      (->environment (find-package '(runtime parser))))))
    (lambda ()
      (discard-char)
      the-unit)))

(parser-table/set-entry! system-global-parser-table
			 '("#u" "#U")
			 parse-object/unit)

;;; Constructors for handling UNIT

(define unit->sexp  
  (make-constructor
   (lambda () #u)
   (lambda (sexp succ fail)
     (if (unit? sexp)
	 (succ)
	 (fail)))))

(define a-unit unit->sexp)


;;;----------------------------------------------------------------------------
;;; SYM-SEXP is a synonym for SYMBOL->SEXP (and should replace it in 
;;; future versions of Scheme+)

(define sym->sexp (make-sexp-constructor 'sym symbol?))




;;;----------------------------------------------------------------------------
;;; DATATYPES

(define-datatype exp
  ($lit exp)
  ($var-ref sym)
  ($proc sym exp)	; In FLAT, sym can be only free var in exp
  ($call exp exp)
  ($if exp exp exp)
  ($let (listof sym) (listof exp) exp)	; FLAT only
  ($pair exp exp)
  ($primop primitive (listof exp))
  ;; Tuples
  ($tuple (listof exp))			; FLAT only
  ($tuple-ref exp int)			; FLAT only
  ($tuple? exp)				; FLAT only
  ($tuple-length exp)			; FLAT only
  ($tuple-append exp exp)		; FLAT only
  ;; Top-level FLAT program -- only used by the LIFTer
  ($program-flat (listof sym) (listof exp) exp)
  )

;;; NOTE: LET expressions are represented by 
;;;   * a list of the indentifiers
;;;   * a list of the expressions for those identifiers
;;;   * a body expression
;;; A LET expression could also have been represented by 
;;;   * a list of bindings that contain both an identifier and an expression
;;;   * a body expression
;;; 

; Expressible Values
(define-datatype exp-val
  (val->exp-val val)
  (error->exp-val string)
  )

(define-datatype value
  (unit->val)
  (int->val  int)
  (bool->val bool)
  (sym->val  sym)
  (procedure->val (-> (value) exp-val))
  (pair->val value value)
  (tuple->val     (listof value))	; FLAT only 
  )



;;;----------------------------------------------------------------------------
;;; EVALUATOR

;;; Curried evaluator performs all dispatches on syntactic types first.
;;; Eval: exp -> env -> exp-val

;;; In this implementation, FLEX-EVAL and FLAT-EVAL are the same.
;;; However, FLEX-EVAL should be given an EXP parsed by FLEX-PARSE
;;; and FLAT-EVAL should be given an EXP parsed by FLAT-PARSE.

(define (flex-eval exp) (eval-exp exp))
(define (flat-eval exp) (eval-exp exp))

(define (flex-eval-empty exp) ((flex-eval exp) the-empty-environment))
(define (flat-eval-empty exp) ((flat-eval exp) the-empty-environment))

(define (eval-exp exp)
  (match exp 
    (($lit xval)            (eval-literal xval))
    (($var-ref v)           (eval-var-ref v))
    (($proc formal body)    (eval-proc formal body))
    (($call rator rand)     (eval-call rator rand))
    (($if test then else)   (eval-if test then else))
    (($let names exps body) (eval-let names exps body))
    (($pair left right)     (eval-pair left right))
    (($primop prim args)    (eval-primop prim args))
    (($tuple exps)          (eval-tuple exps))
    (($tuple-ref exp index) (eval-tuple-ref exp index))
    (($tuple? exp)	    (eval-tuple? exp))
    (($tuple-length exp)    (eval-tuple-length exp))
    (($tuple-append exp1 exp2)       (eval-tuple-append exp1 exp2))
    (($program-flat names exps body) (eval-program names exps body))
    (_ (error 
	(string-append
	 "FLEX/FLAT-EVAL doesn't know how to handle:\n"
	 (write-sexp-to-string (flat-unparse exp)))))
    ))

(define (eval-literal exp-val)
  (lambda (env) exp-val))

(define (eval-var-ref v)
  (lambda (env) (lookup v env)))

(define (eval-proc formal body)
  (let ((body-meaning (eval-exp body)))
    (lambda (env)
      (val->exp-val
       (procedure->val 
	(lambda (val) 
	  (body-meaning (extend-env formal val env))))))))

(define (eval-call rator rand)
  (let ((rator-meaning (eval-exp rator))
	(rand-meaning  (eval-exp rand)))
    (lambda (env)
      (with-procedure (rator-meaning env)
	(lambda (p) 
	  (with-value (rand-meaning env) 
	    p))))))

(define (eval-if test then else)
  (let ((test-meaning (eval-exp test))
	(then-meaning (eval-exp then))
	(else-meaning (eval-exp else)))
    (lambda (env)
      (with-boolean (test-meaning env)
	(lambda (b) 
	  (if b (then-meaning env) (else-meaning env)))))))

(define (eval-let names exps body)
  (let ((exp-meanings (map eval-exp exps))
	(body-meaning (eval-exp body)))
    (lambda (env)
      (with-values (map (lambda (m) (m env)) exp-meanings)
	(lambda (values)
	  (body-meaning (extend-env-by-list 
			 names
			 values
			 env)))))))

(define (eval-pair left right)
  (let ((left-meaning  (eval-exp left))
	(right-meaning (eval-exp right)))
    (lambda (env)
      (with-value (left-meaning env)
	(lambda (left)
	  (with-value (right-meaning env)
	    (lambda (right)
	      (val->exp-val
	       (pair->val left right)))))))))

(define (eval-primop prim args)
  (match prim
    ((make-primitive name n proc)
     (let ((arg-meanings (map eval-exp args)))
       (lambda (env)
	 (with-values (map (lambda (m) (m env)) arg-meanings)
	   (lambda (vals)
	     (apply proc vals))))))))

(define (eval-tuple components)
  (let ((component-meanings (map eval-exp components)))
    (lambda (env)
      (with-values (map (lambda (m) (m env)) component-meanings)
	(lambda (values)
	  (val->exp-val (tuple->val values)))))))

(define (eval-tuple-ref tuple-exp index)
  (let ((tuple-meaning (eval-exp tuple-exp)))
    (lambda (env)
      (with-tuple (tuple-meaning env)
	(lambda (elts)
	  (if (and (>= index 0)
		   (< index (length elts)))
	      (val->exp-val (list-ref elts index))
	      (error->exp-val "TUPLE-REF: Index out of range")))))))

(define (eval-tuple? exp)
  (let ((tuple-meaning (eval-exp exp)))
    (lambda (env)
      (with-value (tuple-meaning env)
	(lambda (v) 
	  (val->exp-val
	   (bool->val
	    (match v
	      ((tuple->val _) #t)
	      (_ #f)))))))))

(define (eval-tuple-length exp)
  (let ((tuple-meaning (eval-exp exp)))
    (lambda (env)
      (with-tuple (tuple-meaning env)
	(lambda (elts) 
	  (val->exp-val
	   (int->val (length elts))))))))

(define (eval-tuple-append tuple-exp1 tuple-exp2)
  (let ((tuple1-meaning (eval-exp tuple-exp1))
	(tuple2-meaning (eval-exp tuple-exp2)))
    (lambda (env)
      (with-tuple (tuple1-meaning env)
	(lambda (elts1)
	  (with-tuple (tuple2-meaning env)
	    (lambda (elts2)
	      (val->exp-val
	       (tuple->val (append elts1 elts2))))))))))

(define (eval-program names exps body)
  (let ((exp-meanings (map eval-exp exps))
	(body-meaning (eval-exp body)))
    (lambda (env)
      (letrec ((new-env
		(lambda (var)
		  (letrec ((loop 
			    (lambda (vs ms)
			      (cond 
			       ((null? vs) (lookup var env))
			       ((same-var? var (car vs))
				((car ms) new-env))
			       (else (loop (cdr vs) (cdr ms)))))))
		    (loop names exp-meanings)))))
	;; Ensure that they are all defined
	(with-values (map (lambda (a-meaning) (a-meaning new-env))
			  exp-meanings)
	  (lambda (ignore)
	    (body-meaning new-env)
	    ))))))


;;;----------------------------------------------------------------------------
;;; ENVIRONMENTS

;;; This injects the output so that normal and unbound lookups both give 
;;; EXP-VALUEs 
(define extend-env 
  (lambda (var1 value env)
    (lambda (var2) 
      (if (same-var? var1 var2)
	  (val->exp-val value)
          (lookup var2 env)))))

(define lookup
  (lambda (var env) (env var)))

(define the-empty-environment
  (lambda (var) (error->exp-val
                 (string-append "Unbound variable: " 
                                (symbol->string var)))))

(define same-var? eq?) 

(define (extend-env-by-list vars vals env)
  (if (null? vars)
      env
      (extend-env (car vars) (car vals) 
		  (extend-env-by-list (cdr vars) (cdr vals) env))))



;;;----------------------------------------------------------------------------
;;; Auxiliary procedures

;; with-value: (-> (exp-val (-> (value) exp-val)) exp-val)
(define (with-value exp-val return)
  (match exp-val
    ((val->exp-val val) (return val))
    ((error->exp-val _) exp-val)
    ))

;; NOTE: This conflicts with Scheme's WITH-VALUES!
;;
;; with-values: (-> (exp-vals (-> (values) exp-val)) exp-val)
(define (with-values exp-vals return)
  (if (null? exp-vals)
      (return '())
      (with-value (car exp-vals)
        (lambda (val)
          (with-values (cdr exp-vals)
	    (lambda (vals)
	      (return (cons val vals))))))))

;; with-integer: (-> (exp-val (-> (int) exp-val)) exp-val)
(define (with-integer exp-val return)
  (with-value exp-val
    (lambda (val)
      (match val
        ((int->val n) (return n))
        (_  (error-with-val 
	     "Non-integer occurs in position where a integer is expected: "
	     val))
	))))

;; with-boolean: (-> (exp-val (-> (bool) exp-val)) exp-val)
(define (with-boolean exp-val return)
  (with-value exp-val
    (lambda (val)
      (match val
        ((bool->val n) (return n))
        (_  (error-with-val 
	     "Non-integer occurs in position where a integer is expected: "
	     val))
	))))

;; with-procedure: (-> (exp-val (-> (procedure) exp-val)) exp-val)
(define (with-procedure exp-val return)
  (with-value exp-val
    (lambda (val)
      (match val
        ((procedure->val p) (return p))
        (_  (error-with-val 
	     "Non-procedure occurs in position where a procedure is expected: "
	     val))
	))))

;; with-tuple: 
;; 	(-> (exp-val (-> ((listof exp-val)) exp-val)) exp-val)
(define (with-tuple exp-val return)
  (with-value exp-val
    (lambda (val)
      (match val
	((tuple->val exps) (return exps))
	(_ (error-with-val
	    "Non-tuple occurs where a tuple is expected: "
	    val))
	))))

;;;----------------------------------------------------------------------------
;;; Primitives: stored in a table to use for looking up primops and 
;;;	building initial flk environment.  

(define-datatype primitive
  (make-primitive sym n-args proc))

(define *flk-primitives-table* '())

(define (add-prim! primitive)
  (set! *flk-primitives-table*
	(cons primitive *flk-primitives-table*))
  unspecific)

(define (lookup-primop sym succ fail)
  (let loop ((lib *flk-primitives-table*))
    (if (null? lib)
	(fail)
	(match (car lib)
	  ((make-primitive prim-name _ _) 
	   (if (eq? sym prim-name)
	       (succ (car lib))
	       (loop (cdr lib))))
	  (_ (loop (cdr lib)))))))


(define (define-general-primitive sym nargs proc)
  (add-prim! (make-primitive sym nargs proc)))

(define (define-typed-primitive sym scheme-proc arg-list return-construtor)
  (define-general-primitive 
   sym
   (length arg-list)
   (add-types sym scheme-proc arg-list return-construtor)))

(define (define-predicate sym obj->value)
  (define-general-primitive
   sym 1
   (lambda (val)
     (val->exp-val
      (bool->val 
       (match val
	 ((obj->value _) #t)
	 (_ #f)))))))

(define (define-logical-primitive sym n-args scheme-proc)
  (define-general-primitive
   sym n-args
   (add-types sym
	      scheme-proc
	      (make-list n-args bool->val)
	      bool->val)))

(define (define-arithop-primitive sym scheme-proc)
  (define-general-primitive
   sym 2
   (add-types sym scheme-proc (list int->val int->val) int->val)))

(define (define-arithop-error-at-0 sym scheme-proc)
  (define-general-primitive
    sym 2
    (add-type-checks sym
		     (lambda (x y)
		       (if (= y 0)
			   'divide-by-zero-error
			   (scheme-proc x y)))
		     (list int->val int->val)
		     (lambda (result)
		       (if (eq? result 'divide-by-zero-error)
			   (error->exp-val "Divide by zero")
			   (val->exp-val (int->val result)))))))

(define (define-arithop-relate sym scheme-proc)
  (define-general-primitive
    sym 2
    (add-types sym scheme-proc (list int->val int->val) bool->val)))


(define (add-types sym scheme-proc arg-list result->val)
  (add-type-checks sym
		   scheme-proc
		   arg-list
		   (lambda (x) (val->exp-val (result->val x)))))

(define (add-type-checks prim-name scheme-proc arg-types result->exp-val)
  (lambda arg-vals
    (define (check-types types vals return)
      (if (null? types)	      ;;; Assume NARGS-checking is done by EVAL-PRIMOP
	  (return '())
	  (match (car vals)
	    (((car types) fst)		;; Types is a list of constructors
	     (check-types (cdr types) 
                          (cdr vals)
			  (lambda (rest)
			    (return (cons fst rest)))))
	    (_ (error->exp-val
		(string-append "Type error in application of primitive: "
			       (symbol->string prim-name)))))))
    (check-types arg-types 
		 arg-vals 
		 (lambda (untagged-args)
		   (result->exp-val (apply scheme-proc untagged-args))))))


;;;----------------------------------------------------------------------------
;;; Primitive Handlers

(define (fl/unit? val)
  (val->exp-val
   (bool->val
    (match val
      ((unit->val) #t)
      (_ #f)))))

(define (fl/pair? val)
  (val->exp-val
   (bool->val
    (match val
      ((pair->val _ _) #t)
      (_ #f)))))

(define (fl/pair-selector op)
  (lambda (val)
    (match val
      ;; left and right are values, so inject 
      ((pair->val left right) (val->exp-val (op left right)))
      (_ (error-with-val "pair selector applied to non-pair" exp-val)))))
     
(define fl/left  (fl/pair-selector (lambda (left right) left)))
(define fl/right (fl/pair-selector (lambda (left right) right)))


;;;----------------------------------------------------------------------------
;;; Put primitives in the table

;; Predicates
(define-general-primitive 'unit? 1 fl/unit?)
(define-predicate 'boolean?   bool->val)
(define-predicate 'integer?   int->val)
(define-predicate 'symbol?    sym->val)
(define-predicate 'procedure? procedure->val)
(define-general-primitive 'pair? 1 fl/pair?)

;; Logical Primitives
(define-logical-primitive 'not?   1 not)
(define-logical-primitive 'and?   2 (lambda (x y) (and x y)))
(define-logical-primitive 'or?    2 (lambda (x y) (or  x y)))
(define-logical-primitive 'bool=? 2 (lambda (x y) (if x y (not y))))

;; Arithmetic Primitives
(define-arithop-primitive  '+   +)
(define-arithop-primitive  '-   -)
(define-arithop-primitive  '*   *)
(define-arithop-error-at-0 '/   quotient)
(define-arithop-error-at-0 'rem remainder)

;; Arithmetic Relations
(define-arithop-relate '=  =)
(define-arithop-relate '/= (lambda (x y) (not (= x y))))
(define-arithop-relate '<  <)
(define-arithop-relate '<= <=)
(define-arithop-relate '>  >)
(define-arithop-relate '>= >=)

;; Symbols
(define-typed-primitive 'sym=? eq? (list sym->val sym->val) bool->val)

;; Pairs
(define-general-primitive 'left  1 fl/left)
(define-general-primitive 'right 1 fl/right)



;;;----------------------------------------------------------------------------
;;; SYMBOL SETS

(define the-empty-set '())

(define set-empty? null?)

(define (set->list set) set)

(define (list->set lst) lst)

(define set-member? 
  (lambda (elt set)
    (cond ((null? set) #f)
	  ((eq? elt (car set)) #t)
	  (else (set-member? elt (cdr set))))))

(define set-adjoin 
  (lambda (elt set)
    (if (set-member? elt set)
	set
	(cons elt set))))

(define set-choose car)

(define set-rest cdr)

(define set-singleton (lambda (elt) (list elt)))

(define set-union 
  (lambda (s1 s2)
    (cond ((set-empty? s1) s2)
	  ((set-member? (set-choose s1) s2)
	   (set-union (set-rest s1) s2))
	  (else (set-adjoin (set-choose s1)
			    (set-union (set-rest s1) s2))))))

(define set-intersection
  (lambda (s1 s2)
    (cond ((set-empty? s1) the-empty-set)
	  ((set-member? (set-choose s1) s2)
	   (set-adjoin (set-choose s1)
		       (set-intersection (set-rest s1) s2)))
	  (else (set-intersection (set-rest s1) s2)))))

(define set-difference 
  (lambda (s1 s2)
    (cond ((set-empty? s1) the-empty-set)
	  ((set-member? (set-choose s1) s2)
	   (set-difference (set-rest s1) s2))
	  (else (set-adjoin (set-choose s1)
			    (set-difference (set-rest s1) s2))))))

(define mapunion 
  (lambda (proc lst)
    (if (null? lst)
	'()
	(set-union (proc (car lst))
		   (mapunion proc (cdr lst))))))

(define (set-subset? s1 s2)
  (every? (lambda (elt) (set-member? elt s2))
	  (set->list s1)))

;;;----------------------------------------------------------------------------
;;; PARSING

(define (parse-common parse sexp language-string)
  (match sexp
    ((unit->sexp)                      ($lit (val->exp-val (unit->val))))
    ((bool->sexp b)                    ($lit (val->exp-val (bool->val b))))
    ((int->sexp i)                     ($lit (val->exp-val (int->val i))))
    (`(SYMBOL ,(sym->sexp s))          ($lit (val->exp-val (sym->val s))))
    ((sym->sexp s)                     ($var-ref s))
    (`(PROC ,(sym->sexp formal) ,body) ($proc formal (parse body)))
    (`(CALL ,rator ,rand)              ($call (parse rator) (parse rand)))
    (`(IF ,test ,then ,else)           ($if (parse test) 
					    (parse then)
					    (parse else)))
    (`(PAIR ,left ,right)              ($pair (parse left) (parse right)))
    (`(PRIMOP ,(sym->sexp op) ,@args)  (parse-primop op args parse))
    (_ (error (string-append "PARSE: Unknown " language-string " expression!")
	      sexp))
    ))

(define (parse-primop op args parser)
  (lookup-primop op
    (lambda (prim)
      (match prim
	((make-primitive name n proc)
	 (if (= n (length args))
	     ($primop prim (map parser args))
	     (error "PARSE: Primop applied to wrong number of arguments: " 
		    (list op args))))))
    (lambda () (error "PARSE: Unknown primop!" op))))

(define (flex-parse sexp)
  (if (flex-sugar? sexp)
      (flex-parse (flex-desugar sexp))
      (parse-common flex-parse sexp "FLEX")))

(define (flat-parse-program sexp)
  (match sexp
    (`(PROGRAM ,(list->sexp bindings) ,body)
     ;; Bindings are mutually recursive and at top-level so okay if they
     ;; have free variables.
     (let ((old-flag check-free-variables?))
       (set! check-free-variables? #f)
       (let ((bound-expressions
	      (map (compose flat-parse binding->val) bindings)))
	        (set! check-free-variables? old-flag)
		($program-flat (map binding->var bindings)
			       bound-expressions
			       (flat-parse body)))))
    (_ (flat-parse sexp))))

(define (flat-parse sexp)
  (if (flat-sugar? sexp)
      (flat-parse (flat-desugar sexp))
      (match sexp
	;; Check free-variables restriction
	(`(PROC ,(sym->sexp formal) ,body) (flat-parse-proc formal body))
	;; Let is primitive in FLAT
	(`(LET ,bindings ,body)            (flat-parse-let bindings body))
	;; Tuples
	(`(TUPLE ,@components)             ($tuple (map flat-parse components)))
	(`(TUPLE-REF ,tuple ,(int->sexp index))
	 ($tuple-ref (flat-parse tuple) index))
	(`(TUPLE? ,exp)                    ($tuple? (flat-parse exp)))
	(`(TUPLE-LENGTH ,exp)              ($tuple-length (flat-parse exp)))
	(`(TUPLE-APPEND ,exp1 ,exp2)       ($tuple-append (flat-parse exp1)
							  (flat-parse exp2)))
	(_ (parse-common flat-parse sexp "FLAT"))
	)))

(define (flat-parse-proc formal body)
  ;; Embed restriction check for abstractions in parser
  (let ((abst ($proc formal (flat-parse body))))
    (if (or (flat? abst) (not check-free-variables?))
	abst
	(error 
	 (string-append
	  "FLAT-PARSE: Not a legal FLAT abstraction\n(contains the free variables "
	  (string-append
	   (with-output-to-string
	     (lambda () (display (list->sexp (set->list (free-vars abst))))))
	   (string-append
	    "):\n"
	    (with-output-to-string
	      (lambda () (display (flat-unparse abst)))))))))))

(define check-free-variables? #t)

(define (flat-parse-let bindings body)
  ($let (map binding->var bindings)
	(map (compose flat-parse binding->val) bindings)
	(flat-parse body)))

;;;----------------------------------------------------------------------------
;;; UNPARSING

(define (make-unparser unparse language-name)
  (lambda (exp)
    (match exp
      (($lit (val->exp-val (unit->val)))   (unit->sexp))
      (($lit (val->exp-val (bool->val b))) (bool->sexp b))
      (($lit (val->exp-val (int->val i)))  (int->sexp i))
      (($lit (val->exp-val (sym->val s)))  `(symbol ,s))
      (($var-ref s)          (sym->sexp s))
      (($proc formal body)   `(PROC ,(sym->sexp formal) ,(unparse body)))
      (($call rator rand)    `(CALL ,(unparse rator) ,(unparse rand)))
      (($if test then else)  `(IF ,(unparse test) ,(unparse then) ,(unparse else)))
      (($pair left right)    (unparse-pair (unparse left) (unparse right)))
      (($primop (make-primitive name _ _) args) `(PRIMOP ,name ,@(map unparse args)))
      (_ (error
	  (string-append "UNPARSE -- unknown " language-name " expression.")))
      )))

(define (unparse-pair left right)
  (match right
    (`#u            `(list ,left))
    (`(LIST ,@elts) `(list ,left ,@elts))
    (_              `(PAIR ,left ,right))))

(define flex-unparse (make-unparser (lambda (exp) (flex-unparse exp))
				    "FLEX"))

(define flat-unparse 
  (let ((recur (make-unparser (lambda (exp) (flat-unparse exp))
			      "FLAT")))
    (lambda (exp)
      (match exp
	(($let names exps body) `(LET ,(map list names (map flat-unparse exps))
				   ,(flat-unparse body)))
	(($tuple components)       `(TUPLE ,@(map flat-unparse components)))
	(($tuple-ref tuple index)  `(TUPLE-REF ,(flat-unparse tuple) 
					       ,index))
	(($tuple? exp)             `(TUPLE? ,(flat-unparse exp)))
	(($tuple-length exp)       `(TUPLE-LENGTH ,(flat-unparse exp)))
	(($tuple-append exp1 exp2) `(TUPLE-APPEND ,(flat-unparse exp1) 
						  ,(flat-unparse exp2)))
	(($program-flat names exps body)
	 `(PROGRAM ,(map list names (map flat-unparse exps))
		   ,(flat-unparse body)))
	(_ (recur exp))))))


;;;----------------------------------------------------------------------------
;;; DESUGARING
;;;
;;; Build an environment mapping sugar keyword to a sexp-transform.

(define (flex-sugar? sexp) (sugar? sexp flex-keywords))
(define (flat-sugar? sexp)
  ;; LET is in the FLAT-kernel
  (match sexp
    (`(LET ,(a-list _) ,_) #f)
    (_ (sugar? sexp flat-keywords))))

(define flex-keywords '(proc call if pair primop symbol))
(define flat-keywords (append 
		       flex-keywords
		       '(let tuple tuple-ref tuple? tuple-length tuple-append)))

(define (flex-desugar sexp) (desugar sexp))
(define (flat-desugar sexp) (desugar sexp))

(define *sugar-keywords* '())

(define *sugar-env* 
  (lambda (keyword)
    (error "Syntax Error: unbound sugar keyword" keyword)))

(define (sugar? sexp keywords)
  (match sexp
    (`(lambda ,(a-list _) ,_) #t)	;; curried abstraction
    (`(,(a-symbol sym) ,@_) (or (memq sym *sugar-keywords*)
				(not (memq sym keywords))))
    (`(,operator ,@operands) #t)	;; application 
    (_ #f)))

(define (desugar sexp)
  ;; The standard environment is handled differently than in desugaring rules
  ((lookup (keyword sexp) *sugar-env*) sexp))

(define (keyword sexp)
  (match sexp
    (`(,(a-symbol keyword) ,@_) (if (memq keyword *sugar-keywords*)
				    keyword
				    implicit-call-tag))
    (`(,operator ,@operands)  implicit-call-tag)
    (_ (error "KEYWORD: unrecognized syntax" sexp))
    ))

(define (define-sugar keyword transformer)
  (if (null? (memq keyword *sugar-keywords*))
      (set! *sugar-keywords* (cons keyword *sugar-keywords*)))
  ;; Extend environment 
  (let ((old-env *sugar-env*))
    (set! *sugar-env* (lambda (sym)
			(if (eq? sym keyword)
			    transformer
			    (lookup sym old-env))))))

(define-sugar 'list
  (lambda (sexp)
    (match sexp
      (`(LIST) #u)
      (`(LIST ,first ,@rest)
       `(PAIR ,first (LIST ,@rest)))
      (_ (error "DESUGAR-LIST: invalid syntax" sexp)))))

(define-sugar 'quote
  (lambda (sexp)
    (match sexp
      (`(QUOTE ,item)
       (match item
	 ((bool->sexp b) item)
	 ((int->sexp  n) item)
	 ((sym->sexp s) `(SYMBOL ,s))
	 ((list->sexp lst) 
	  `(LIST ,@(map (lambda (elt) `(QUOTE ,elt)) lst)))
	 (_ (error "DESUGAR-QUOTE: invalid syntax" sexp))))
      (_ (error "DESUGAR-QUOTE: invalid syntax" sexp)))))

(define-sugar 'lambda
  (lambda (sexp)
    (match sexp
      (`(LAMBDA () ,body) 
       `(PROC ,(fresh-var) ,body))
      (`(LAMBDA (,a-formal) ,body)
       `(PROC ,a-formal ,body))
      (`(LAMBDA (,first ,@rest) ,body)
       `(PROC ,first
	      (LAMBDA (,@rest)
		,body)))
      (_ (error "DESUGAR-LAMBDA: invalid syntax" sexp)))))
		 
(define implicit-call-tag (list '*implicit-call*))

(define-sugar implicit-call-tag
  (lambda (sexp)
    (match sexp
      (`(,operator)
       `(CALL ,operator #u))
      (`(,operator ,one-arg)
       `(CALL ,operator ,one-arg))
      (`(,operator ,first-arg ,@rest)
       `((CALL ,operator ,first-arg) ,@rest))
      (_ (error "DESUGAR-IMPLICIT-CALL: invalid syntax" sexp)))))

(define-sugar 'cond
  (lambda (sexp)
    (match sexp
      (`(COND) #u)
      (`(COND (ELSE ,default))
       default)
      (`(COND (ELSE ,default) ,@rest)
       (error "DESUGAR-COND: else not last clause" sexp))
      (`(COND (,test ,consequent) ,@rest)
       `(IF ,test ,consequent (COND ,@rest)))
      (_ (error "DESUGAR-COND: invalid syntax" sexp)))))
	
(define-sugar 'and
  (lambda (sexp)
    (match sexp
      (`(AND) (bool->sexp #t))
      (`(AND ,first ,@rest)
       `(IF ,first (AND ,@rest) #f))
      (_ (error "DESUGAR-AND: invalid syntax" sexp)))))

(define-sugar 'or
  (lambda (sexp)
    (match sexp
      (`(OR) (bool->sexp #f))
      (`(OR ,first ,@rest)
       `(IF ,first #t (OR ,@rest)))
      (_ (error "DESUGAR-OR: invalid syntax" sexp)))))

;; Only in FLEX
(define-sugar 'let
  (lambda (sexp)
    (match sexp
      (`(LET (,@bindings) ,body)
       ;; Syntax of bindings enforced by binding selectors
       `((LAMBDA ,(list->sexp (map binding->var bindings)) ,body)
	 ,@(map binding->val bindings)))
      (_ (error "DESUGAR-LET: invalid syntax" sexp)))))

(define binding->var
  (lambda (sexp)
    (match sexp
      (`(,(sym->sexp var) ,_) var)
      (_ (error "BINDING->VAR: Not a binding!" sexp)))))

(define binding->val
  (lambda (sexp)
    (match sexp
      (`(,_ ,val) val)
      (_ (error "BINDING->VAL: Not a binding!" sexp)))))



;;;----------------------------------------------------------------------------
; FRESH-VAR
; Generate a new variable.

; Fresh variables are of the form `[VAR-n]', where n is the next integer
; from the counter maintained by FRESH-VAR.  The name is surrounded 
; by square brackets ---  these are illegal in FL identifiers but not 
; in FLK identifiers. (No check is performed here to ensure this 
; constraint holds on FL identifiers; but we are helped by the fact that  
; the Scheme reader doesn't recognize '[' and ']'.)

(define fresh-var
  (let ((counter 1))
    (lambda ()
      (let ((val counter))
	(set! counter (+ counter 1))
	(string->symbol (string-append "[var-" (number->string val) "]"))))))


;;;----------------------------------------------------------------------------
;;; FREE VARIABLES

(define (free-vars exp)
  (match exp
    (($lit _) the-empty-set)
    (($var-ref id) (set-singleton id))
    (($proc formal body) (set-difference (free-vars body)
					 (set-singleton formal)))
    (($call rator rand) (set-union (free-vars rator)
				   (free-vars rand)))
    (($if test consequent alternate)
     (set-union (free-vars test)
		(set-union (free-vars consequent)
			   (free-vars alternate))))
    (($primop op args) (mapunion free-vars args))
    (($pair exp1 exp2) (set-union (free-vars exp1) (free-vars exp2)))
    (($let ids exps body)
     (set-union (mapunion free-vars exps)
		(set-difference (free-vars body)
				(list->set ids))))
    (($tuple components)       (mapunion free-vars components))
    (($tuple-ref tuple _)      (free-vars tuple))
    (($tuple? exp)             (free-vars exp))
    (($tuple-length exp)       (free-vars exp))
    (($tuple-append exp1 exp2) (set-union (free-vars exp1) (free-vars exp2)))
    (($program-flat ids exps body)
     (set-difference (set-union (mapunion free-vars exps) 
				(free-vars body))
		     (list->set ids)))
    ))

;;; Checks that a FLAT expression is legal ---
;;; i.e., all abstractions are closed

(define (non-scoped? exp) (flat? exp))

(define (flat? exp)
  (match exp
    (($lit _) #t)
    (($var-ref _) #t)
    (($proc formal body)
     (and (flat? body)
	  (set-subset? (free-vars body) (set-singleton formal))))
    (($call rator rand) (and (flat? rator) (flat? rand)))
    (($if test consequent alternate) (and (flat? test) 
					  (flat? consequent)
					  (flat? alternate)))
    (($primop op-name args)    (every? flat? args))
    (($pair exp1 exp2)         (and (flat? exp1) (flat? exp2)))
    (($let ids exps body)      (and (every? flat? exps) (flat? body)))
    (($tuple components)       (every? flat? components))
    (($tuple-ref tuple _)      (flat? tuple))
    (($tuple? exp)             (flat? exp))
    (($tuple-length exp)       (flat? exp))
    (($tuple-append exp1 exp2) (and (flat? exp1) (flat? exp2)))
    (($program-flat ids exps body) #f)	;; Kludge...
    ))
  

;;;----------------------------------------------------------------------------
;;; READ-EVAL-PRINT LOOP

(define (make-repl prompt parse eval)
  (lambda ()
    (let loop ((env the-empty-environment))
      (newline)
      (newline)
      (write-string prompt)
      (let ((sexp (read)))
	(newline)
	(cond ((eq? sexp 'quit) 'done)
	      ((define-sexp? sexp) 
	       (let ((exp-meaning (eval (parse (definition-value sexp))))
		     (name (definition-name sexp)))
		 (match (exp-meaning env)
		   ((val->exp-val v)
		    (begin
		      (display
		       (string-append ";Updating " (symbol->string name) 
				      " --> "      (value->string v)))
		      (loop (extend-env name v env))))
		   (error-val
		    (begin
		      (display (unparse-exp-value error-val))
		      (loop env))))))
	      (else (display (unparse-exp-value ((eval (parse sexp)) env)))
		    (loop env)))))))

(define flex-repl (make-repl "flex=> " flex-parse flex-eval))

(define flat-repl (make-repl "flat=> " flat-parse-program flat-eval))

(define false-symbol (string->symbol "#f"))

(define (unparse-exp-value exp-val)
  (match exp-val
    ((error->exp-val string) 
     (string->sexp (string-append "[FLEX/FLAT Error: " string "]")))
    ((val->exp-val v) (unparse-value v))))

(define (unparse-value val)
  (match val
    ((unit->val)   #u)
    ((int->val  n) (int->sexp n))
    ((bool->val b) (if b (bool->sexp b) false-symbol))
    ((sym->val s) `',(sym->sexp s))
    ((pair->val left right) (unparse-pair (unparse-value left)
					  (unparse-value right)))
    ((procedure->val p) `procedure)
    ((tuple->val vals) `(tuple ,@(map unparse-value vals)))
    ))


(define (error-with-val error-string val)
  (error->exp-val
   (string-append error-string "\n\t" (value->string val))))
    
(define (value->string val)
  (with-output-to-string
    (lambda () (display (unparse-value val)))))



;;;----------------------------------------------------------------------------
;;; UTILITIES

(define (every? pred lst)
  (if (null? lst)
      #t
      (and (pred (car lst))
	   (every? pred (cdr lst)))))

(define (compose f g)
  (lambda (x) (f (g x))))
 
(define (define-sexp? sexp)
  (match sexp
    (`(define ,(a-symbol name) ,value-exp) #t)
    (_ #f)))

(define (definition-name def)
  (match def
    (`(define ,(a-symbol name) ,value-exp) name)
    (_ (error (string-append "DEFINITION-NAME -- not a definition")))))

(define (definition-value def)
  (match def
    (`(define ,(a-symbol name) ,value-exp) value-exp)
    (_ (error (string-append "DEFINITION-VALUE -- not a definition")))))


;;;----------------------------------------------------------------------------
;;; TESTING

(define (test-translate translator)
  (begin
    (analyze-it translator (get-input "test=> "))
    #u))

(define (analyze-it translator flex-exp)
  (let ((flat-exp (translator flex-exp))
	(validinput (set-empty? (free-vars flex-exp))))
    (newline) 
    (newline) 
    (write-string "Input expression (FLEX): ")
    (pp (flex-unparse flex-exp))
    (newline) 
    (warn-on-unbound-vars "INPUT" validinput)
    (newline)
    (write-string "Translated expression (FLAT): ")
    (pp (flat-unparse flat-exp))
    (newline)
    (warn-on-bogus-translator validinput flat-exp)
    flat-exp))

(define (get-input prompt)
  (newline)
  (write-string prompt)
  (flex-parse (read)))

(define (test-loop translator)
  (letrec 
      ((testloop
	(lambda ()
	  (begin
	    (newline)
	    (let ((flex-exp (get-input "testloop=> ")))
	      (let ((flat-exp (analyze-it translator flex-exp)))
		(begin
		  (newline)
		  (write-string "Input expression value: ")
		  (pp (unparse-exp-value (flex-eval-empty flex-exp)))
		  (newline)
		  (newline)
		  (write-string "Translated expression value: ")
		  (pp (unparse-exp-value (flat-eval-empty flat-exp)))
		  (newline)
		  (testloop))))))))
    (testloop)))

(define (warn-on-unbound-vars string validinput)
  (if (not validinput)
      (begin
	(newline)
	(write-string "----------------------------------------------------\n")
	(write-string (string-append  
		       "*** " string
		       " EXPRESSION CONTAINS UNBOUND VARIABLES! ***\n"))
	(write-string "----------------------------------------------------\n")
	)
      #u))

(define (warn-on-bogus-translator validinput flat-exp)
  (if (and validinput (not (non-scoped? flat-exp)))
      (begin
	(newline)
	(write-string "----------------------------------------------\n")
	(write-string "*** TRANSLATOR DOESN'T WORK ON THIS CASE! ***\n")
	(write-string "(Some PROCs contain free variables!)\n")
	(write-string "----------------------------------------------\n")
	)
      #u))


;;;----------------------------------------------------------------------------
;;; LIFTer

;lift: flat-exp -> flat-exp
(define (lift flat-exp)
  (walk flat-exp (lambda (new-exp ids procs)
		   ($program-flat ids procs new-exp))))

(define (walk exp return)
  (match exp
    (($proc formal body) 
     (let ((id (fresh-var)))
       (walk body
	     (lambda (new-body ids procs)
	       (return ($var-ref id)
		       (cons id ids)
		       (cons ($proc formal new-body) procs))))))
    (($call rator rand)   (walk-list (list rator rand)     $call return))
    (($if test consq alt) (walk-list (list test consq alt) $if   return))
    (($pair left right)   (walk-list (list left right)     $pair return))
    (($let ids exps body) (walk-list (cons body exps)
				     (lambda new-list
				       ($let ids 
					     (cdr new-list)
					     (car new-list)))
				     return))
    (($primop prim exps)  (walk-list exps
				     (lambda new-exps
				       ($primop prim new-exps))
				     return))
    (($tuple exps)        (walk-list exps 
				     (lambda new-exps ($tuple new-exps))
				     return))
    (($tuple-ref exp index) (walk-list (list exp)
				       (lambda (new-exp)
					 ($tuple-ref new-exp index))
				       return))
    (($tuple? exp)       (walk-list (list exp) $tuple? return))
    (($tuple-length exp) (walk-list (list exp) $tuple-length return))
    (($tuple-append exp1 exp2) (walk-list (list exp1 exp2)
					  $tuple-append
					  return))
    (_ (return exp '() '()))
    ))

(define (walk-list listof-exps constructor return)
  (let loop ((listof-exps listof-exps)
	     (return (lambda (new-list ids procs)
		       (return (apply constructor new-list) ids procs))))
    (if (null? listof-exps)
	(return '() '() '())
	(walk (car listof-exps)
	      (lambda (new-car car-ids car-procs)
		(loop (cdr listof-exps) 
		      (lambda (new-cdr cdr-ids cdr-procs)
			(return (cons   new-car   new-cdr)
				(append car-ids   cdr-ids)
				(append car-procs cdr-procs)))))))))

(define (translate-and-lift translator)
  (lambda (sexp)
    (flat-unparse (lift (translator (flex-parse sexp))))))

(define (lift-flat sexp)
  (flat-unparse (lift (flat-parse sexp))))


;; eg. (lift-flat '(call (proc x x) 3))
;; ==> (program (([var-4] (proc x x))) (call [var-4] 3))

(define (lift-loop-on-flex)
  (let loop ()
    (newline)
    (newline)
    (write-string "lift-flex=> ")
    (let* ((sexp (read))
	   (flex-exp   (flex-parse sexp))
	   (validinput (set-empty? (free-vars flex-exp)))
	   (lifted-exp (lift flex-exp))
	   (validlift  (set-empty? (free-vars lifted-exp)))
	   )
      (newline)
      (newline)
      (write-string "Input expression: ")
      (pp (flex-unparse flex-exp))
      (warn-on-unbound-vars "INTPUT" validinput)
      (newline)
      (newline)
      (write-string "Lifted expression: ")
      (pp (flat-unparse lifted-exp))
      (warn-on-unbound-vars "LIFTED" validlift)
      (newline)
      (newline)
      (write-string "Input expression value: ")
      (pp (unparse-exp-value (flex-eval-empty flex-exp)))
      (newline)
      (newline)
      (write-string "Lifted expression value: ")
      (pp (unparse-exp-value (flat-eval-empty lifted-exp)))
      (loop))))

(define (lift-loop-with-translate translator)
  (let loop ()
    (newline)
    (newline)
    (write-string "lift-trans=> ")
    (let* ((sexp (read))
	   (flex-exp   (flex-parse sexp))
	   (validinput (set-empty? (free-vars flex-exp)))
	   (flat-exp   (translator flex-exp))
	   (lifted-exp (lift flat-exp))
	   (validlift  (set-empty? (free-vars lifted-exp)))
	   )
      (newline)
      (newline)
      (write-string "Input expression: ")
      (pp (flex-unparse flex-exp))
      (warn-on-unbound-vars "INTPUT" validinput)
      (newline)
      (newline)
      (write-string "Translated expression: ")
      (pp (flat-unparse flat-exp))
      (warn-on-bogus-translator validinput flat-exp)
      (newline)
      (newline)
      (write-string "Lifted expression: ")
      (pp (flat-unparse lifted-exp))
      (warn-on-unbound-vars "LIFTED" validlift)
      (newline)
      (newline)
      (write-string "Input expression value: ")
      (pp (unparse-exp-value (flex-eval-empty flex-exp)))
      (newline)
      (newline)
      (write-string "Translated expression value: ")
      (pp (unparse-exp-value (flat-eval-empty flat-exp)))
      (newline)
      (newline)
      (write-string "Lifted expression value: ")
      (pp (unparse-exp-value (flat-eval-empty lifted-exp)))
      (loop))))