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

#lang racket

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

(require "parser.scm")

;; NOTE: lots of bugs in this: i8 fixes them

;;; data
;;

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

(define builtins^
  `((cons . cons)
    ;;
    (print . print)))

(define builtins
  `((cons . ,cons)
    (print . ,print)))

(define specials '(lambda))

(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)
	 (cons `(,(sid define meta) ,name ,(resolve-exp source env^ spec))
	       (resolve-prg (cdr prg) env^ 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)))))

    (else (error "invalid syntax" 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)))
	   (interpret-prg (cdr prg)
			  (cons (cons name value) env)))))))

(define (interpret-exp exp env)
  (cond ((or (number? exp) (boolean? exp) (string? exp)) exp)
	((sid? exp) (cdr (assoc (sid-id exp) env)))
	((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^)
       (interpret-exp b (cons x x^) env)))

    ))


;;; main
;;

(define (check filename)
  (resolve-prg (parse-file filename) builtins^ specials))

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