scheme-interpreter-story/initial-work/i10.scm

#lang racket

(require racket/match)
(require racket/include)

(require "parser.scm")

;;; rubbish/time waste because immutable conses
;;

(define (set-assoc-box! soc key value)
  ;; if it already exists mutate it
  ;; else cons it on
  (cond ((assoc key soc) =>
	 (lambda (entry)
	   (set-box-value! (cdr entry) value)
	   soc))
	(else (cons (cons key (box value)) soc))))

(define (assoc-box-ref soc key default)
  (cond ((assoc key soc) =>
	 (lambda (entry)
	   (box-value (cdr entry))))
	(else default)))

;;; data
;;

(define (print s) (display s) (newline))

(struct box ((value #:mutable)) #:transparent)

(define-syntax define-builtins
  (syntax-rules ()
    ((define-builtins builtins^ builtins <name> ...)
     (begin
       (define builtins^
	 `((<name> . <name>) ...))
       (define builtins
	 `((<name> . ,(box <name>)) ...))))))

(define-builtins builtins^ builtins
  cons car cdr
  box box-value set-box-value!
  = eq? equal? not
  + - * /
  display newline print

  ;; predicates from R5RS  
  boolean?
  pair?
  symbol?
  number?
  char?
  string?
  vector?
  procedure?
  )


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



;;; resolve
;;

(define (resolve-prg prg env^ spec)
  (if (null? prg)
      '()
      (match (car prg)
	(`(,(sid define meta) ,name ,source)
         ;; think about whether we should gensym here or not
         (let ((env^ (cons (cons (sid-id name) (sid-id name)) env^)))
           (cons `(,(sid define meta) ,name ,(resolve-exp source env^ spec))
                 (resolve-prg (cdr prg)
                              env^
                              (remove (sid-id name) spec))))))))

(define (resolve-exp exp env^ spec)
  (cond ((or (number? exp) (boolean? exp) (string? exp)) exp)
	((sid? exp)
	 ;;
	 ;; we see a variable
	 ;; ensure that it is bound
	 ;; and freshen it with a gensym if so
	 ;;
	 (cond ((assoc (sid-id exp) env^) => (lambda (i) (sid (cdr i) (sid-metadata exp))))
	       (else (error "unbound variable" exp))))
	((list? exp)
	 (if (and (sid? (car exp)) (member (sid-id (car exp)) spec))
	     (resolve-special exp env^ spec)
	     (map (lambda (i) (resolve-exp i env^ spec)) exp)))
	(else (error "syntax error" exp))))

(define (resolve-special exp env^ spec)
  (match exp

    (`(,(sid 'lambda m1) ,args ,b)
     (let ((args^ (map gensym (map sid-id args))))
       `(,(special 'lambda m1)
	 ,(map (lambda (a x) (sid x (sid-metadata a))) args args^)
	 ,(resolve-exp b (append (map cons (map sid-id args) args^) env^)
                       (remove* args spec)))))

    (`(,(sid 'if m1) ,t ,c ,a)
     `(,(special 'if m1)
       ,(resolve-exp t env^ spec)
       ,(resolve-exp c env^ spec)
       ,(resolve-exp a env^ spec)))
    (`(,(sid 'if m1) ,t ,c)
     (error "illegal: sussmans pirate at" m1))

    (`(,(sid 'begin m1) . ,stmts)
     (if (null? stmts)
	 (error "bad begin at" m1)
	 `(,(special 'begin m1)
	   . ,(map (lambda (e) (resolve-exp e env^ spec)) stmts))))

    (`(,(sid 'quote m1) ,data)
     `(,(special 'quote m1)
       ,(syx->datum data)))

    (`(,(sid 'let m1) ,bindings ,body)
     (resolve-exp
      `((,(sid 'lambda m1) ,(map car bindings) ,body)
        . ,(map cadr bindings))
      env^ spec))

    (else (error "invalid syntax" exp (syx->datum exp)))))

;;; interpret
;;

(define (interpret-prg prg env)
  (if (null? prg)
      #t
      (match (car prg)
	(`(,(sid define meta) ,name ,exp)
	 (let ((value (interpret-exp exp env)))
	   (set-assoc-box! env (sid-id name) value)
	   (interpret-prg (cdr prg) env))))))

(define (interpret-exp exp env)
  (cond ((or (number? exp) (boolean? exp) (string? exp)) exp)
	((sid? exp) (assoc-box-ref env (sid-id exp) #f))
	((list? exp)
	 (if (special? (car exp))
	     (interpret-special exp env)
             (let ((f (interpret-exp (car exp) env)))
               (unless (procedure? f)
                 (error "can't apply non-procedure" (car exp)))
               (apply f
                      (map (lambda (i) (interpret-exp i env)) (cdr exp))))))
        (else (error "?" exp))))

(define (interpret-special exp env)
  (match exp

    (`(,(special 'lambda meta) ,args ,b)
     (lambda args^
       (let ((env (append (map (lambda (x x^)
				 (cons (sid-id x) (box x^)))
			       args args^) env)))
       (interpret-exp b env))))

    (`(,(special 'if meta) ,t ,c ,a)
     (if (interpret-exp t env)
         (interpret-exp c env)
         (interpret-exp a env)))

    (`(,(special 'begin meta) . ,stmts)
     (let loop ((stmts stmts))
       (if (null? (cdr stmts))
	   (interpret-exp (car stmts) env) ;; tail position
	   (begin (interpret-exp (car stmts) env)
                  (loop (cdr stmts))))))

    (`(,(special 'quote meta) ,d)
     d)

    ))


;;; main
;;

(define (check filename)
  (let ((r (resolve-prg (parse-file filename) builtins^ specials)))
    (print r)
    (print (syx->datum r))))

(define (go filename)
  (let ((resolved (resolve-prg (parse-file filename) builtins^ specials)))
    (interpret-prg resolved builtins)))