scheme-interpreter-story/scope-set-env.scm

#lang racket

(require "box.scm")
(require "counter.scm")
(require "sets.scm")

(provide ss-env
	 ss-env-scope-counter
	 ss-env-current-scope-set
	 ss-env-binding-table

	 ss-env-make

	 extend-env

	 add-scopeset-binding!
         scope-set-lookup)

(struct ss-env ((scope-counter)
		(current-scope-set)
		(binding-table))
	#:transparent)

(define (ss-env-make assoc)
  ;; create a ss-env from a basic assoc lookup table
  ;;  it does this by turning each (<name> . <value>) entry from the input
  ;;  into <name> * empty-set -> <value>
  ;;  in our scope-set binding table
  ;;
  ;; assumes every entry in the assoc list has a unique name
  (let ((ht (make-hash)))
    (for-each (lambda (entry)
		(hash-set! ht (car entry) (list (cons '() (cdr entry)))))
	      assoc)
    (ss-env (make-counter)
	    '()
	    ht)))

(define (extend-env env scop)
  (ss-env (ss-env-scope-counter env)
	  (sorted-list-insert + scop (ss-env-current-scope-set env))
	  (ss-env-binding-table env)))

;; the binding table is a hash table:
;;
;; name -> (set to value)
;;
;; where each 'set to value' is an
;; assoc list mapping set of scopes -> value
;; and it is sorted by length (largest set first)

(define (add-scopeset-binding! env scop name value)
  (let* ((set (sorted-list-insert + scop (ss-env-current-scope-set env)))
	 (tbl (ss-env-binding-table env))
	 (sets->values (hash-ref tbl name '())))
    (hash-set! tbl name
	       (sorted-list-insert (lambda (entry) (- (length (car entry))))
				   (cons set value)
                                   sets->values))))

;; This is it

(define (scope-set-lookup env id set)
  ;; errors if unbound
  ;; errors if ambiguous
  ;;
  ;; TODO: optimization: exit early if entries are smaller than current best score
  ;;
  (let loop ((best #f)
	     (best-score #f)
	     (sets (hash-ref (ss-env-binding-table env) id)))
    (if (null? sets)
	(if best
	    (cdr best)
	    (error "unbound variable" (list id set)))
	(let ((entry (car sets)))
	  (if (subset-of? + (car entry) set)
	      (let ((score (length (car entry))))
		(if (or (not best-score) (> score best-score))
		    (loop entry score (cdr sets))
		    (loop best best-score (cdr sets))))
	      (loop best best-score (cdr sets)))))))