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

#lang racket

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

(require "parser.scm")

;;; 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> . ,<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))

(struct special ((id #:mutable) (metadata #:mutable)) #:transparent)


;;; 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) (,(sid x m2)) ,b)
     (let ((x^ (gensym x)))
       `(,(special 'lambda m1)
	 (,x^)
	 ,(resolve-exp b (cons (cons x x^) env^)
		       (remove x 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)))

    (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)))
	   (hash-set! 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) (hash-ref env (sid-id exp) #f))
	((list? exp)
	 (if (special? (car exp))
	     (interpret-special exp env)
	     (apply (interpret-exp (car exp) env)
		    (map (lambda (i) (interpret-exp i env)) (cdr exp)))))
        (else (error "?" exp))))

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

    (`(,(special 'lambda meta) (,x) ,b)
     (lambda (x^)
       (hash-set! env x x^)
       (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)
  (resolve-prg (parse-file filename) builtins^ specials))

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