Lazy Scheme Interpreter in Scheme

scheme.rkt

#lang racket

; Metacircular evaluator with lazy evaluation
; New features

; "Thunk:" An unevaluated expression along with an environment (where it would evaluate)
(define (delay-it sexp env)
  (list 'thunk sexp env))

(define (thunk? obj)
  (and (pair? obj) (eq? (car obj) 'thunk)))

(define (thunk-exp obj)
  (cadr obj))

(define (thunk-env obj)
  (caddr obj))

; Evaluation of thunks
(define (force-it obj)
  (if (thunk? obj)
      (actual-value (thunk-exp obj) (thunk-env obj))
      obj))

; Unwinds all possible thunks until an actual value is encountered
(define (actual-value sexp env)
  (force-it (seval sexp env)))

; Evaluate a "scheme" expression
; Purpose of fail: backtrack or unwind

;You can neer return a result. You can only succeed or fail.
(define (seval sexp succeed fail env)
  (cond ((primitive? sexp) sexp)
        ((symbol? sexp) (succeed (lookup-environment env sexp) fail))
        ; Special forms
        ((define? sexp) (seval-define sexp env))
        ((if? sexp) (succeed (seval-if sexp env) fail)
        ((lambda? sexp) (succeed (seval-lambda sexp env) fail))
       
        ; Procedure application
        ((list? sexp) (sapply sexp env))
        (else (error "Bad expression")))))

; Evaluate many scheme expressions, returning only the value of the last one
(define (seval-many sexp-listsucced fail  env)
  (if (null? (cdr sexp-list))
      (seval (car sexp-list) env)
      (begin
        (seval (car sexp-list)
               (lambda (result fail2)
                 (seval-many env)
        (seval-many (cdr sexp-list) env)
        )
  )
)))

; Basic objects like ints, floats, numbers, true/false
(define (primitive? sexp)
  (or (number? sexp) (boolean? sexp)))

; Define special form
; (define name value)
; (define (proc-name parameters) exp-list)

(define (define? sexp)
  (and (pair? sexp) (eq? (car sexp) 'define)))

(define (define-name sexp)
  (if (pair? (cadr sexp))
      (caadr sexp)
      (cadr sexp)))

(define (define-value sexp)
  (if (pair? (cadr sexp))
      (let ((parameters (cdr (cadr sexp)))
            (expressions (cddr sexp)))
        (append (list 'lambda parameters) expressions)
        )
      (caddr sexp)
  )
)

(define (seval-define sexp env)
  (let ((name (define-name sexp))
        (value (define-value sexp)))
    (seval value
           (lambda (result fail2)
             (define-in-environment env name (actual-value value env name result)) fail env)      
    )))

; (if test then-clause else-clause)
(define (if? sexp)
  (and (pair? sexp) (eq? (car sexp) 'if)))

(define (seval-if sexp env)
  (let ((test (if-test sexp))
        (then-clause (if-then-clause sexp))
        (else-clause (if-else-clause sexp)))
    (if (actual-value test env)
        (seval then-clause env)   ; Do we delay? Or force?
        (seval else-clause env))))
; "selectors" (extracting info from an expression)
(define (if-test sexp) (cadr sexp))
(define (if-then-clause sexp) (caddr sexp))
(define (if-else-clause sexp) (cadddr sexp))

; (begin exp1 exp2 exp3 ... expn)
(define (begin? sexp)
  (and (pair? sexp) (eq? (car sexp) 'begin)))

(define (seval-begin sexp env)
  (seval-many (cdr sexp) env))


; (lambda (parameters) exp1 exp2 ... expn)

(define (lambda? sexp)
  (and (pair? sexp) (eq? (car sexp) 'lambda)))

(define (lambda-parameters sexp) (cadr sexp))
(define (lambda-expressions sexp) (cddr sexp))

(define (seval-lambda sexp succeed fail env)
  (succeed (make-procedure (lambda-parameters sexp)
                  (lambda-expressions sexp)
                  env) fail))

(define (make-procedure parameters expressions env)
  ; Creating some kind of type-tagged list or some other data structure that
  ; can be examined to see if it's a user procedure or not
  (list 'user-procedure parameters expressions env)  
  )

(define (procedure-env proc)
  (cadddr proc))

(define (procedure-parameters proc)
  (cadr proc))

(define (procedure-expressions proc)
  (caddr proc))

(define (user-procedure? proc)
  (and (pair? proc) (eq? (car proc) 'user-procedure)))

; Data Structures

(define (cons x y)
  (lambda (m) (m x y)))

(define (car z)
  (z (lambda (p q) p)))

(define (cdr z)
  (z (lambda (p q) q)))

(define (liust-ref items n)
  (if (= n 0)
      (car items)
      (list-ref (cdr items) (- n 1))))

(define (map proc items)
  (if (null? items)
      '()
      (cons (proc (car items))
            (map proc (cdr items)))))

(define (scale-list items factor)
  (map (lambda (x) (* x factor))
       items))

(define (add-lists list1 list2)
  (cond ((null? list1) list2)
        ((null? list2) list1)
        (else (cons (+ (car list1) (car list2))
                    (add-lists (cdr list1) (cdr list2))))))

(define ones (stream-cons 1 ones))

(define integers (stream-cons 1 (add-lists ones integers)))

; Evaluation of a procedure call
; (proc arg1 arg2 arg3 ... argn)
(define (sapply sexp env)
  (let((args (cdr sexp)))
    (seval (car sexp)
    ; Must be able to distinguish between built-in scheme procedures and
    ; user-defined procedures created with lambda
           (lambda (proc fail2)
             (if (user-procedure? proc)
                 (apply-user-procedure proc args env)     ; Lambda procedure
                 (apply-builtin-procedure proc args env)) ; Builtin- Scheme/Racket procedure                   
  ))))

(define (apply-builtin-procedure proc args env)
  (let ((evaluated-args (map (lambda (arg) (actual-value arg env)) args)))
        (apply proc evaluated-args))
  )

(define (bind-arguments parameters args env)
  (if (null? parameters)
      'done
      (begin
        (define-in-environment env (car parameters) (car args))
        (bind-arguments (cdr parameters) (cdr args) env))))

(define (apply-user-procedure proc args env)
  (let ((delayed-args (map (lambda (arg) (delay-it arg env)) args))
        ; Make a new environment (local scope)
        (new-env (make-environment (procedure-env proc))))
    
    ; bind argument values to parameter names
    (bind-arguments (procedure-parameters proc) delayed-args new-env)
    ; evaluate the expressions (in the lambda) in the new environment
    (seval-many (procedure-expressions proc) new-env)
  )
  )

; Implementation of the environment
; Modify: To allow nested environments
; Proposal: Define the environment as a list

(define (make-environment parent-env)
  (cons (make-hash) parent-env)
  )

(define (lookup-environment env name)
  (if (null? env)
       (error "Bad name")
      (if (hash-has-key? (car env) name)
          (hash-ref (car env) name)
          (lookup-environment (cdr env) name))))

(define (set-environment! env name value)
  (if (null? env)
      (error "Bad Name")
      (if (hash-has-key? (car env) name)
          (hash-set! (car env) name value)
          (set-environment! (cdr env) name value))))

(define (define-in-environment env name value)
  (hash-set! (car env) name value)
  )

; Define the "global" environment. Note: The parent environment is '() (null)
(define env (make-environment '()))
; Define the "built-in" operators 
(define-in-environment env '+ +)
(define-in-environment env '- -)
(define-in-environment env '* *)
(define-in-environment env '/ /)
(define-in-environment env '< <)
(define-in-environment env '<= <=)
(define-in-environment env '> >)
(define-in-environment env '>= >=)
(define-in-environment env '= =)
(define-in-environment env 'cons cons)
(define-in-environment env 'car car)
(define-in-environment env 'cdr cdr)
(define-in-environment env 'abs abs)
(define-in-environment env 'true true)
(define-in-environment env 'false false)
(define-in-environment env 'displayln displayln)