;;; target.ss
;;; Copyright 1999 Stuart A. Kurtz
;;; 
;;; A data-directed evaluator for a scheme-like language.

;;; This implementation of a meta-circular evaluator differs
;;; from that of Abelson & Sussman's in several important ways.
;;;
;;; 1. We representation the denotable objects of the
;;;    target-language uniformly using attached type tags.
;;;    This permits the evaluator to be written in a data-directed
;;;    style; and facilitates extention.
;;;
;;; 2. Although the evaluator itself is not written in a
;;;    continuation-passing style, portions of the runtime
;;;    system are written in continuation-passing style.
;;;
;;; 3. Rather than using alists for binding structures, we use
;;;    parallel key/value lists.

;;; Program overview:
;;; 1. The evaluator and  driver
;;; 2. Environments and Tables
;;;    a. Generic Access
;;;    b. Environments
;;;    c. Tables
;;; 3. Denotable types
;;;    a. number
;;;    b. symbol
;;;    c. bool
;;;    d. null
;;;    e. cons
;;;    f. primitive procedure
;;;    g. special form
;;;    h. procedure
;;; 4. Runtime system
;;;    a. IO
;;;    b. Primitive functions
;;;    b. Implementations of special forms
;;;    c. The initial runtime environment
;;;
;;; run...

;;; 1. The evaluator and driver

(define (mc-eval object environment)
  ((get (type object) 'evaluate) object environment))

(define (mc-driver)
  (let ((prompt "mc> ")
        (the-environment (make-initial-environment)))
    (define (read-eval-print-loop)
      (display prompt)
      (let ((input (mc-read)))
        (mc-print (mc-eval input the-environment))
        (newline)
        (read-eval-print-loop)))
    (read-eval-print-loop)))

;;; 2. Environments and Tables
;;; 2a. Generic Access

(define (access keys values key success failure)
  (cond ((or (null? keys)
             (null? values))
         (failure))
        ((eq? (car keys) key)
         (success values))
        (else
         (access (cdr keys) (cdr values) key success failure))))

;;; 2b. Environments

(define (make-environment enclosing-environment keys values)
  (list '*environment* enclosing-environment keys values))

(define (enclosing-environment environment)
  (cadr environment))

(define (keys environment)
  (caddr environment))

(define (values environment)
  (cadddr environment))

(define (splice-binding! environment key value)
  (define (splice! ref val)
    (set-car! ref (cons val (car ref))))
  (splice! (cddr environment) key)
  (splice! (cdddr environment) value))

(define (mc-define environment key value)
  (define (success reference)
    (set-car! reference value))
  (define (failure)
    (splice-binding! environment key value))
  (access (keys environment)
          (values environment)
          key
          success
          failure))

(define (mc-set! environment key value)
  (define (success reference)
    (set-car! reference value))
  (define (failure)
    (let ((next-environment (enclosing-environment environment)))
      (if (null? next-environment)
          (error "set! -- unknown variable" key)
          (mc-set! next-environment key value))))
  (access (keys environment)
          (values environment)
          key
          success
          failure))

(define (lookup environment key unbound-proc)
  (define (success reference)
    (car reference))
  (define (failure)
    (let ((next-environment (enclosing-environment environment)))
      (if (null? next-environment)
          (unbound-proc)
          (lookup next-environment key unbound-proc))))
  (access (keys environment)
          (values environment)
          key
          success
          failure))

;;; 2c. Tables

(define (make-table)
  (make-environment '() '() '()))

(define (lookup-in-table table keys)
  (define (unbound-proc)
    (error "unbound key" (car keys)))
  (if (null? keys)
      table
      (lookup-in-table (lookup table (car keys) unbound-proc)
                       (cdr keys))))

(define (bind-in-table! table keys value)
  (define (unbound-proc)
    (let ((new-table (make-table)))
      (mc-define table (car keys) new-table)
      (bind-in-table! new-table (cdr keys) value)
      new-table))
  (if (null? (cdr keys))
      (mc-define table (car keys) value)
      (bind-in-table! (lookup table (car keys) unbound-proc)
                      (cdr keys)
                      value)))

(define op-table (make-table))

(define (put key1 key2 value)
  (bind-in-table! op-table (list key1 key2) value))

(define (get key1 key2)
  (lookup-in-table op-table (list key1 key2)))


;;; 3. Denotable types
;;; All denotable values are "boxed" with a type symbol.

(define (box type data)
  (cons type data))

(define (unbox object)
  (cdr object))

(define (type object)
  (car object))

(define (has-type? t)
  (lambda (obj)
    (eq? (type obj) t)))

(define (self-evaluating expression environment)
  expression)

(define (primitive-printer obj)
  (display (unbox obj)))

;;; 3a. Denotable type -- number

(define mc-number? (has-type? 'number))
(define (apply-number num args env)
  (define (iter k arglist)
    (cond ((< k 0) mc-null)
          ((mc-null? arglist) mc-null)
          ((zero? k) (mc-eval (mc-car arglist) env))
          (else
           (iter (- k 1) (mc-cdr arglist)))))
  (iter (unbox num) args))

(put 'number 'evaluate self-evaluating)
(put 'number 'display primitive-printer)
; (put 'number 'apply apply-number)

;;; 3b. Denotable type -- symbol

(define mc-symbol? (has-type? 'symbol))
(put 'symbol
     'evaluate
     (lambda (boxed-symbol environment)
       (lookup environment (unbox boxed-symbol)
               (lambda () (error "unbound symbol" (unbox boxed-symbol))))))

(put 'symbol 'display primitive-printer)

;;; 3c. Denotable type -- bool

(define mc-boolean? (has-type? 'bool))
(put 'bool 'evaluate self-evaluating)
(put 'bool 'display primitive-printer)

;;; 3d. Denotable type --- null

(define mc-null? (has-type? 'null))
(define mc-null (box 'null '()))
(put 'null 'evaluate self-evaluating)
(put 'null 'display primitive-printer)

;;; 3e. Denotable type -- cons

(define mc-cons? (has-type? 'cons))

(define (mc-cons a b)
  (box 'cons (cons a b)))

(define (mc-car a)
  (car (unbox a)))

(define (mc-cdr a)
  (cdr (unbox a)))

(define (print-list obj)
  (define (iter ls sep)
    (cond ((mc-cons? ls)
           (display sep)
           (mc-print (mc-car ls))
           (iter (mc-cdr ls) " "))
          ((mc-null? ls)
           (display ")"))
          (else
           (display " . ")
           (mc-print ls)
           (display ")"))))
  (display "(")
  (iter obj ""))

(define (mc->scheme-list mc-list)
  (cond ((mc-null? mc-list)
         '())
        ((mc-cons? mc-list)
         (cons (mc-car mc-list)
               (mc->scheme-list (mc-cdr mc-list))))
        (else
         (error "mc->scheme-list unexpected argument" mc-list))))


(define (eval-application obj env)
  (let ((op (mc-eval (mc-car obj) env)))
    ((get (type op) 'apply) op (mc-cdr obj) env)))

(put 'cons 'evaluate eval-application) ;;; stub!!
(put 'cons 'display print-list)

;;; 3f. Denotable type -- primitive procedure

(define mc-primitive? (has-type? 'primitive))

(define (make-primitive name proc)
  (box 'primitive
       (cons name proc)))

(define (primitive-name primitive)
  (car (unbox primitive)))

(define (primitive-proc primitive)
  (cdr (unbox primitive)))

(define (apply-primitive prim args env)
  (define (build-args as)
    (if (mc-null? as)
        '()
        (cons (mc-eval (mc-car as) env)
              (build-args (mc-cdr as)))))
  (apply (primitive-proc prim) (build-args args)))

(put 'primitive 'evaluate self-evaluating)
(put 'primitive 'display
     (lambda (obj)
       (display "<primitive:")
       (display (primitive-name obj))
       (display ">")))
(put 'primitive 'apply apply-primitive)

;;; 3g. Denotable type -- special form

(define mc-special? (has-type? 'special))
(define (make-special name proc)
  (box 'special (cons proc name)))

(define (special-proc special)
  (car (unbox special)))

(define (special-name special)
  (cdr (unbox special)))

(define (display-special special)
  (display "<special-form:")
  (display (special-name special))
  (display ">"))

(define (apply-special special args env)
  ((special-proc special) args env))

(put 'special 'evaluate self-evaluating)
(put 'special 'display display-special)
(put 'special 'apply apply-special)

;;; 3h. Denotable type -- procedure

(define mc-procedure (has-type? 'procedure))

(define (make-procedure args body def-env)
  (box 'procedure
       (list (map unbox (mc->scheme-list args))
             body
             def-env)))

(define (procedure-args proc)
  (car (unbox proc)))

(define (procedure-body proc)
  (cadr (unbox proc)))

(define (procedure-env proc)
  (caddr (unbox proc)))

(define (display-proc proc)
  (display "<procedure>"))

(define (apply-proc proc arg-forms env)
  (runtime-begin (procedure-body proc)
                 (make-environment (procedure-env proc)
                                   (procedure-args proc)
                                   (map (lambda (arg-form)
                                          (mc-eval arg-form env))
                                        (mc->scheme-list arg-forms)))))

(put 'procedure 'evaluator self-evaluating)
(put 'procedure 'display display-proc)
(put 'procedure 'apply apply-proc)

;;; 4. Runtime system
;;; 4a. IO

(define (mc-read)
  (convert-to-mc (read)))

(define (convert-to-mc obj)
  (cond ((number? obj)
         (box 'number obj))
        ((symbol? obj)
         (box 'symbol obj))
        ((boolean? obj)
         (box 'bool obj))
        ((null? obj)
         (box 'null obj))
        ((pair? obj)
         (mc-cons (convert-to-mc (car obj))
                  (convert-to-mc (cdr obj))))
        (else
         (error "convert-to-mc: object of unknown type" obj))))

(define (mc-print obj)
  ((get (type obj) 'display) obj))

;;; 3b. Primitive functions

(define (runtime-plus . args)
  (box 'number
       (apply + (map unbox args))))

(define (runtime-minus a b)
  (box 'number
       (- (unbox a)
          (unbox b))))

(define (runtime-times . args)
  (box 'number
       (apply * (map unbox args))))

(define (runtime-divide a b)
  (box 'number
       (/ (unbox a)
          (unbox b))))

(define (runtime-= a b)
  (box 'bool
       (= (unbox a)
          (unbox b))))

(define (display-source-representation a)
  (display a)
  (newline)
  a)

(define (boolean-box pred)
  (lambda (x)
    (box 'bool (pred x))))

;;; 4b. Implementations of special forms

(define (runtime-if args env)
  (if (unbox (mc-eval (mc-car args) env))
      (mc-eval (mc-car (mc-cdr args)) env)
      (mc-eval (mc-car (mc-cdr (mc-cdr args))) env)))

(define (runtime-begin args env)
  (if (mc-null? (mc-cdr args))
      (mc-eval (mc-car args) env)
      (begin (mc-eval (mc-car args) env)
             (runtime-begin (mc-cdr args) env))))

(define (runtime-lambda args env)
  (make-procedure (mc-car args)
                  (mc-cdr args)
                  env))

(define (runtime-quote args env)
  (mc-car args))

(define (runtime-define args env)
  (if (mc-cons? (mc-car args))
      (begin
        ; sugared form of function definition
        (mc-define env
                   (unbox (mc-car (mc-car args)))
                   (make-procedure (mc-cdr (mc-car args))
                                   (mc-cdr args)
                                   env))
        (mc-car (mc-car args)))
      (begin
        (mc-define env
                   (unbox (mc-car args))
                   (mc-eval (mc-car (mc-cdr args))
                            env))
        (mc-car args))))

(define (runtime-eval args env)
  (mc-eval (mc-eval (mc-car args) env) env))

;;; 4c. The initial runtime environment

(define (make-initial-environment)
  (let ((the-environment (make-environment '() '() '())))
    (define (bind! key value)
      (mc-define the-environment key value))
    (define (eval expr)
      (mc-eval (convert-to-mc expr) the-environment))
    (bind! '+ (make-primitive "+" runtime-plus))
    (bind! '- (make-primitive "-" runtime-minus))
    (bind! '* (make-primitive "*" runtime-times))
    (bind! '/ (make-primitive "/" runtime-divide))
    (bind! '= (make-primitive "=" runtime-=))
    (bind! 'car (make-primitive "car" mc-car))
    (bind! 'cdr (make-primitive "cdr" mc-cdr))
    (bind! 'cons (make-primitive "cons" mc-cons))
    (bind! 'null? (make-primitive "null?" (boolean-box mc-null?)))
    (bind! 'pair? (make-primitive "pair?" (boolean-box mc-cons?)))
    (bind! 'symbol? (make-primitive "symbol?" (boolean-box mc-symbol?)))
    (bind! 'display-source-representation (make-primitive "display-source-representation"
                                                          display-source-representation))
    (bind! 'if (make-special "if" runtime-if))
    (bind! 'begin (make-special "begin" runtime-begin))
    (bind! 'lambda (make-special "lambda" runtime-lambda))
    (bind! 'quote (make-special "quote" runtime-quote))
    (bind! 'define (make-special "define" runtime-define))
    (bind! 'eval (make-special "eval" runtime-eval))
    (eval '(begin
             (define (map f xs)
               (if (null? xs)
                   '()
                   (cons (f (car xs))
                         (map f (cdr xs)))))
             (define (curry f)
               (lambda (x)
                 (lambda (y)
                   (f x y))))
             ))
    the-environment))

;;; run...

(mc-driver)