scheme-interpreter-story/resolve.scm

#lang racket

(require racket/match)
(require (only-in srfi/1 every))

(require "utilities.scm")
(require "counter.scm")
(require "box.scm")
(require "sets.scm")
(require "scope-set-env.scm")
(require "syntax.scm")

(provide resolve-program)

;;; resolve
;;

;; NOTE: Right now nothing actually adds to the 'set'
;; metadata of a syntax node
;;
;; once we have macros, they will need to do this

(define specials
  '((lambda special)
    (begin special)
    (if special)
    (quote special)))

(define (special? x)
  (and (pair? x) (eq? 'special (car x))))

(define (resolve-program prg builtins)
  (let ((assoc-table
	 (append (map (lambda (entry)
			(cons (car entry) (list 'variable (car entry))))
		      builtins)
		 specials)))
    (resolve-program^ prg assoc-table)))

(define (resolve-program^ prg tbl)
  (if (null? prg)
      '()
      (let ((res (resolve-definition (car prg) tbl)))
	;; TODO: need to add the new definition
	;; the loop could move into resolve def to make that easy
	(cons res (resolve-program (cdr prg) tbl)))))

(define (resolve-definition def builtins)
  ;; TODO: what if someone shadows DEFINE
  (let ((me-meta '((source . "resolve-definition"))))
    (match def

      ((list (syx 'id 'define meta-1) (syx 'id name meta-2) source)
       ;;
       ;; A simple definition (define <name> <single-form>)
       ;;
       ;; We make the definition as in scope before resolving it
       ;; this allows for recursive functions
       ;; TODO (update-env! env (make-dummy-binding name))

       (let ((ss-env (ss-env-make builtins)))
	 (list (syx 'id 'define meta-1) (syx 'id name meta-2)
	       (resolve-exp source ss-env))))

      ((list (syx 'id 'define meta-1) (list* header args) source)
       ;;
       ;; Handle implicit lambda definitions
       ;;
       ;; (define (f x y) y) ~> (define f (lambda (x y) y))
       ;;
       (resolve-definition
	(list (syx 'id 'define meta-1)
	      header
	      (list (syx 'id 'lambda me-meta) args source))
	builtins))

      ((list* (syx 'id 'define meta-1) header source source*)
       ;;
       ;; Handle implicit begin inside a definition
       ;;
       (resolve-definition
	(list (syx 'id 'define meta-1) header
	      (list* (syx 'id 'begin me-meta) source source*))
	builtins))

      (else
       (error "resolve-definition: Bad definition!" def)))))

(define (resolve-exp exp ss-env)
  (define (ss-lookup exp)
    (scope-set-lookup ss-env
		      (syx-id exp)
		      (union +
                             (syx-set exp)
                             (ss-env-current-scope-set ss-env))))
  (cond ((syx-atomic? exp) exp)
	((syx-id? exp)
	 (ss-lookup exp))
	((null? exp)
	 '())
	((and (pair? exp)
	      (syx-id? (car exp))
	      (special? (ss-lookup (car exp))))
	 ;; A special form or macro
	 ;; TODO: do we have to actually do a resolution here?
	 ;; I think we do because otherwise you could rename
	 ;; one special as another and it'd get them mixed up
	 ;; make sure to create a test for this
	 (resolve-special exp ss-env))
	((pair? exp)
	 ;; A regular function application
	 (cons (resolve-exp (car exp) ss-env)
	       (resolve-exp (cdr exp) ss-env)))
	(else (error "resolve-exp: bad syntax!" exp))))

;; changes
;;
;; env stores a scope counter
;; env stores the current scope set (nested)
;; env stores a hash table mapping name * set --> value
;;
;; new function (add-scopeset-binding! env scop name value)
;;  adds a scope set binding to the environment hash table
;;  name * (current scope u {scop}) --> value
;;
;; changed function (extend-env env scop)
;;  now this adds scop to the current scop set of our env

(define (resolve-special exp env)
  (let ((me-meta '((source . "resolve-special"))))
    (match exp

      ((list (syx 'id 'lambda meta) params body)
       ;; We see a lambda special form
       ;; Validate that it is well formed
       (unless (every syx-id? params)
	       (error "malformed lambda: parameters are not variables" exp))
       ;; create a new scope for this binder
       (let* ((sm ((ss-env-scope-counter env)))
	      ;; making a mapping var,scope u {sm} -> gensym(var)
	      (param-names (map syx-id params))
	      (gen-params (map (lambda (p n)
                                 (syx (syx-type p)
                                      (gensym n)
                                      (syx-metadata p)))
                               params
                               param-names)))
	 (for-each (lambda (nm gen)
		     (add-scopeset-binding! env sm nm gen))
		   param-names gen-params)
	 (list (syx 'special 'lambda meta)
               gen-params
	       (resolve-exp body (extend-env env sm)))))
      ((list* (syx 'id 'lambda meta) params body body*)
       ;; This case just handles the implicit begin of lambda
       (resolve-exp
	(list (syx 'id 'lambda meta) params
	      (list* (syx 'id 'begin me-meta) body body*))
	env))

      ((list (syx 'id 'begin meta))
       (error "empty begin"))
      ((list* (syx 'id 'begin meta) exps)
       (list* (syx 'special 'begin meta) (map (lambda (exp) (resolve-exp exp env)) exps)))

      ((list (syx 'id 'if meta) t c a)
       (list (syx 'special 'if meta)
	     (resolve-exp t env)
	     (resolve-exp c env)
	     (resolve-exp a env)))
      ((list (syx 'id 'if meta) t c)
       (error "illegal sussmans pirate" exp))

      ((list (syx 'id 'quote meta) m)
       (syx->datum m))

      (else (error "invalid special form syntax in resolve-special" exp)))))