;; JSJ

;; Problem: see p. 62 of text or notes from
;; Mon Jul  1 10:11:48 EST 1996

;; Allowable expressions:
;;   x
;;   (lambda (x ...) M)
;;   (M1 M2)

;; This version handles lambda lists of arbitrary number of formals.

;; --------------------------------------------
;; REQUIRES record.ss

(load "record.ss")

;; --------------------------------------------



(define-record varref (var))
(define-record lambda (formals body))
(define-record app (rator rands))


;; find-lexical-address-ONE operates on a single level environment (a
;; list of atoms) which contains the symbol e, which is a single atom. 

;; find-lexical-address returns either an integer, or 'free

(define scope 
  (lambda (exp)
    (letrec
      ((scope (lambda (pe cenv)
		(variant-case pe
		  (varref (var)
		    (list 
		      (find-lexical-address var cenv)
		      ':
		      var))
		  (lambda (formals body)
		    (list
		      'lambda
		      formals
		      (scope body (cons formals cenv))))
		  (app (rator rands)
		    (cons (scope rator cenv)
		      (map (lambda (x) (scope x cenv))
			rands))))))
       (find-lexical-address 
	 (lambda (e cenv)
	   (call/cc
	     (lambda (free-variable)
	       (letrec
		 ((find-lexical-address
		    (lambda (cenv n)
		      (cond
			((null? cenv)	; reached end of environment!
			 (free-variable 'free))
			((memq e (car cenv))
			 (list n (find-lexical-address-ONE e (car cenv))))
			(else
			  (find-lexical-address (cdr cenv) (+ 1 n))))))
		  (find-lexical-address-ONE
		    (lambda (e cenv)
		      (letrec
			((find-lexical-address
			   (lambda (cenv)
			     (cond
			       ((eq? (car cenv) e)
				0)
			       (else
				 (+ 1 (find-lexical-address (cdr cenv))))))))
			(find-lexical-address cenv))))
		  )
		 (find-lexical-address cenv 0))))))
       (parse-exp
	 (lambda (e)
	   (cond
	     ((atom? e) (make-varref e))
	     ((and (list? e)		; a cheap hack
		   (eq? (car e) 'lambda))
	      (make-lambda (cadr e)	; formals
		(parse-exp (caddr e))))	; body

	     (else			; else application
	       (make-app (parse-exp (car e)) ; operator
		 (map parse-exp (cdr e))))))) ; operands

       )
      (scope (parse-exp exp) '()))))


;; a potentially useful function to have around
;; (generates a type predicate based on symbol eq-ness)

(define type-of
  (lambda (sym)
    (lambda (x)
      (and (pair? x)
	   (eq? (car x) sym)))))