Scarecrow a lisp 1 like interpreter. It is written in Racket, a plt-scheme dialect

kernel-revisited.scm

#lang racket/base

(require racket/match)

;; -----------------------------------   Evaluator.
(define (eval expr env) 
  (match expr
    ;; __environment__ will return the current environment/state of the interpreter.
    [`__environment__ env]
         
    [(? boolean?)                              (evaluator 'literal expr)]
    [(? string?)                               (evaluator 'literal expr)]
    [(? number?)                               (evaluator 'literal expr)]    
    [(? symbol?)                               (evaluator 'symbol  env expr)]
                      
    [`(set! ,key ,value)                       (evaluator 'set!    key value)]

    [`(define (,name . ,bindings) ,function)   (evaluator 'define  name expr )]
    [`(define ,name ,value)                    (evaluator 'set!    name value)]

    [`(if ,ec ,et ,ef)                         (evaluator 'if      env ec et ef)]
    [`(let ,bindings ,body)                    (evaluator 'let     env bindings body)]
    [`(lambda ,bindings ,body)                 (evaluator 'lambda  env expr )]
    [`(begin . ,expr)                          (evaluator 'begin   env expr)]

    [`(,f . ,args)                             (evaluator 'apply-proc  env
                                                                       (eval f env)
                                                                       (map ((evaluator 'evlis) env) args)) ]
    [_ error "Unknown expression type -- EVAL" expr] ))


;; -----------------------------------   Evaluation

(define (Evaluator)
  (define (evlis env) (lambda (exp) (eval exp env)))
  
  (define (*literal* expr)          expr)
  (define (*symbol*  env expr)      ((Env 'look-up) expr env) )
  (define (*set!*    key value)     ((Env 'set!)    key value))
  (define (*define*  name expr)     ((Env 'set!)    name (list 'closure expr)))
    
  (define (*if*      env ec et ef)  (if (eval ec env) (eval et env) (eval ef env)))
  (define (*lambda*  env expr)      (list 'closure expr env))
  (define (*begin*   env expr)      (last (map ((evaluator 'evlis) env) expr)))
  (define (*let* env bindings body) (eval body ((Env 'extended-env*) env
                                                              (map car bindings)
                                                              (map ((evaluator 'evlis) env) (map cadr bindings)))))
  
  (define (apply-proc env f values)
    (match f
       [`(closure (lambda ,vs ,body) ,env)
        (eval body ((Env 'extended-env*) env vs values))]
           
       [`(closure (define (,name . ,vs) ,body) )
        (eval body ((Env 'extended-env*) env.global vs values))]
       
       [_ (f values)] ))
  
  (lambda (method . args)
    (case method
      [(literal) (apply *literal*  args)]      
      [(symbol)  (apply *symbol*   args)]
      [(set!)    (apply *set!*     args)]
      [(define)  (apply *define*   args)]
      [(if)      (apply *if*       args)]
      [(lambda)  (apply *lambda*   args)]
      [(begin)   (apply *begin*    args)]
      [(let)     (apply *let*      args)]
      
      [(evlis)   evlis] 
      [(apply-proc) (apply apply-proc args)   ] )))

(define evaluator (Evaluator))
        
;; -----------------------------------   Environment
(define-struct box ([value #:mutable]))

(define env.global (make-immutable-hash '()))

(define Env
  (lambda(method)
    (case method
      [(set)             (lambda (env key value)  (hash-set env key value))]
      [(set!)            (lambda (key value)      (set-box-value! (hash-ref env.global key) value))]
      [(look-up)         (lambda (expr env)     (box-value (hash-ref env expr)))]
      [(extended-env*)   (lambda (env vars values)
                           (match `(,vars ,values)
                               [`((,v . ,vars) (,val . ,values))
                                ((Env 'extended-env*)  ((Env 'set) env v (make-box val))  vars values)]
                               
                               [`(() ())  env] ))] )))

;; -----------------------------------   Primitives
(define-syntax definitial 
  (syntax-rules ()    
    [(definitial name)
     (set! env.global ((Env 'set) env.global name (make-box null))) ]
    
    [(definitial name value)
     (set! env.global ((Env 'set) env.global name (make-box value))) ]))    

(define-syntax-rule (defprimitive name value arity)
  (definitial name 
    (lambda (values) 
      (if (= arity (length values))
          (apply value values)      
          (error "Incorrect arity"
                 (list 'name values))))))

(define-syntax-rule (defpredicate  name value arity)
  (defprimitive name
    (lambda values (or (apply value values) #f))
    arity ) )

(define (last lst)
  (if (pair? lst)
      (if (pair? (cdr lst))
          (last (cdr lst))
          (car lst))
      (error "parameter should be a non empty list")))

;; -----------------------------------
(define (eval-program  program)
  (evaluate (cons 'begin program)))
  

scarecrow-tests.scm

#lang racket/base
  
(require rackunit "kernel-revisited.rkt")

(define (test description test-case result)  
  (check-equal? (evaluate test-case) result description)
  (display "."))

;; Test Simple data types. 
(test "the false value" #f #f)
(test "The true  value " #t #t)

(test "Positive numbers." 1 1)
(test "Negative numbers." -123 -123)

(test "String." "hola" "hola")

(test "Simple porcedure call" '(= 1 1) #t)
(test "Another Simple Porcedure Call" '(= 1 2) #f)

;; The If statement
(test "a true condition in if statament." '(if #t "hola" "adios") "hola")
(test "a false condition in if statament." '(if #f "hola" "adios") "adios")

(test "Execute form in a if statament true branch."
      '(if #t (+ 1 1) (- 1 1))
      2)

(test "Execute form in a if statament false branch."
      '(if #f (+ 1 1) (- 1 1))
      0 )

(test "Execute form in condition if statament."
      '(if (eq? 1 1) (+ 1 1) (- 1 1))
      2)   

(test "Check nested forms in a if statement." 
       '(if (boolean? (eq? (= (- 2 1) (+ 1 0) )#t)) (- 1 (+ 1 1)) (- 1 1)) 
       -1 )

;; Begin
(test "Return the last s-expr evaluation in a begin"
      '(begin (+ 1 1) (+ 2 2))
      4)

(test "Set a variable from a 'begin scope"
      '(begin (define x 1) (set! x "hola") x)
      "hola")

(test "Set a variable from a 'lambda scope"
      '(begin (lambda (y) (set! x "hola")) x)
      "hola") 
      

;; Lambda 
(test  "Call a Lambda Function."
       '((lambda (y) y) 1)
       1 )

(test "Execute a lambda function."      
      '((lambda (y) (+ 1 y)) 1) 
      2 )

(test "Lambda do not polute the "
     '(begin (set! x "outter x") ((lambda(x) x) "inner x") x)
     "outter x")

(test "Nest begin clause."
      '(begin (+ 1 1) (begin (+ 1 1) (+ 1 1)) (+ (+ 1 2) 100))
      103 )

(test "Nested begin clause."
      '(begin (+ 1 1) (begin (+ 1 1) (+ 1 1))  1)
      1 )            

(test  "Nest begin clause."
       '(begin (+ 1 1) (begin (+ 1 1) (+ 1 1)) (+ (+ 1 2) 100)) 
       103)

;; Let 
(test "simple let scope."
      '(let ((x 1) ) x)
      1)

(test "let accept procedure to set up lexical variables."
      '(let ((x (+ 1 1)) ) x)
      2)


;;(test "let accept procedure to set up lexical variables."
;;      '(let ((x (+ 1 1)) )
;;         (begin (set! x 3) 
;;               x))
;;     3)

(test "let create assign lambda to a lexical scoped variable."
      '(let ((increment (lambda (x) (+ 1 x))))
               (increment 1))
      2)

(test "A more complex interaction between scopes.  (+ (* (+ 4 5) 4) 3)"
      '(let ((x 3) (y 4))
        (+ (let ((x (+ y 5)))
             (* x y)) x ))
      39)

(test "Nested let scope"
      '(let ((x 1))
         (let ((x 3))
           x))
      3)



;; Other classic functions 
(test "A the factorial function"
      '(begin (define (fact n)
                (if (= 0 n)
                    1
                    (* n (fact (- n 1)))))
              (fact 3))
      6)

(test "defining a simple function"
      '(begin (define x 1) x) 
      1)
      
;; Extensions 

(test "inspect the environment"
      '__environment__
      env.global)