A Scheme intrepreter that allow you to run top level programs.

evaluator-test.scm

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

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

;; 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")

;; 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 "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 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)

interpreter-based.scm

#lang racket/base

(require racket/match)

;; -------------------------------------    Define booleans
(define the-false-value #f)

;; -------------------------------------    Data Types Predicates.
(define (boolean? x )
  (or (eq? x the-false-value)
      (eq? x (not the-false-value)) ))

;; -----------------------------------   Evaluator.
(define (eval expr env)
  (match expr
    [`(__environment__) env]
    [(? boolean?) expr]
    [(? string?)  expr]
    [(? number?)  expr]
    [(? symbol?)  (env.look-up expr env)]
    
    [`(set! ,key ,value ) (env.set!  key value)]

    [`(if ,ec ,et ,ef) (if (eval ec env)
                           (eval et env)
                           (eval ef env))]

    [`(let ,bindings ,body )
        (eval body (extended-env* env
                                  (map car bindings)
                                  (map (evlis env) (map cadr bindings))))]

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

    [`(lambda ,bindings ,body) 
        (list 'closure expr env)]

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

; applies a procedure to arguments:
(define (apply-proc f values)   
  (match f
    [`(closure (lambda ,vs ,body) ,env)
     (eval body (extended-env* env vs values))]
    
    [`(closure (define (,name . ,vs) ,body) )
     (eval body (extended-env* env.global vs values))]
    
    [_ (f values)]))

(define (evlis  env) 
  (lambda (exp) (eval exp env)))

;; -----------------------------------   Environment
(define-struct cell ([value #:mutable]))
(define env.global (make-immutable-hash '()))

(define (env.set   env key value)  (hash-set env key value))
(define (env.set!      key value)
  (set-cell-value! (hash-ref env.global key) value))

(define (env.look-up expr env )
  (cell-value (hash-ref env expr)))

(define (extended-env* env vars values)
  (match `(,vars ,values)
     [`((,v . ,vars) (,val . ,values))
          (extended-env*  (env.set env v (make-cell val))  vars values)]
         
     [`(() ())  env] ))

;; -----------------------------------   Primitives
(define-syntax definitial 
  (syntax-rules ()    
    [(definitial name)
     (set! env.global (env.set env.global name (make-cell null))) ]
    
    [(definitial name value)
     (set! env.global (env.set env.global name (make-cell 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) the-false-value))
    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)))
  
(define (evaluate program)
  (if (list? program)
      (map define->bindings program)
      '())
  (eval program env.global))

(define (define->bindings define)  
  (match define
    [`(define (,name . ,bindings ) ,body)   (definitial name)]
    [`(define ,name ,value)  (definitial name)]
    [else    '()]))

(definitial #t #t)
(definitial #f the-false-value)
(definitial 'nil '())

(defprimitive 'cons cons 2)
(defprimitive 'car car 1)
(defprimitive 'cdr cdr 1)
(defpredicate 'pair? pair? 1)
(defpredicate 'boolean? boolean? 1)
(defpredicate 'symbol? symbol? 1)
(defpredicate 'procedure? procedure? 1)
(defprimitive 'eq? eq? 2)
(defpredicate 'eq? eq? 2)
(defprimitive '+ + 2)
(defprimitive '- - 2)
(defpredicate '= = 2)
(defpredicate '> > 2)
(defpredicate '< < 2)    
(defprimitive '* * 2)
(defpredicate '<= <= 2)
(defpredicate '>= >= 2)
(defprimitive 'remainder remainder 2)
(defprimitive 'display display 1)

;; (module-path-index-resolve (car (identifier-binding  #'define-syntax-rule)))
(provide evaluate)