the-little-schemer/chapter-10/reorganized-code.scm

;; ============
;; INTRODUCTION
;; ============

;; This chapter deals with the writing of a simple interpreter for
;; S-expressions. The code is reorganized to be easier to understand.

;; =============
;; PREREQUISITES
;; =============

;; These are defined elsewhere in the book and simply used in this chapter.

(define first car)
(define rest cdr)
(define second cadr)
(define third caddr)
(define build list)

(define (atom? sth)
  (and (not (pair? sth))
       (not (null? sth))))

;; ===========================
;; DATA ABSTRACTION FOR TABLES
;; ===========================

;; Tables or better environments could be implemented in many ways. Here we use
;; lists for simplicity. Lists do, in this case, incur a performance cost when
;; looking up bindings in the environment of an expression, but not in the case
;; of extending an environment.

;; Ideally what one would like to have is a data structure, that has constant
;; time random access (O(1)) and constant time adding to the environment.

;; To abstract from the underlying data structure we define the interface in
;; terms of procedures. This will enable us to keep changes local, if we want to
;; change the underlying data structure.

(define new-entry build)
(define extend-table cons)
(define empty-table '())  ; not defined in the book

(define lookup-in-entry
  (lambda (name entry lookup-fallback-proc)
    (lookup-in-entry-helper name
                            (first entry)
                            (second entry)
                            lookup-fallback-proc)))

(define lookup-in-entry-helper
  (lambda (name keys values lookup-fallback-proc)
    (cond
     [(null? keys) (lookup-fallback-proc name)]
     [(eq? name (first keys)) (first values)]
     [else
      (lookup-in-entry-helper name
                              (rest keys)
                              (rest values)
                              lookup-fallback-proc)])))

(define lookup-in-empty-table  ; not defined in the book
  (lambda (name)
    "Hopefully this code will never be run. It will result in an error."
    ;; Here is the original version of the code from the book:
    #;(car '())
    ;; Instead we are goint to raise a proper error. The book does not do this,
    ;; in order to not have to introduce exception handling as well.
    (throw 'identifier-not-in-table name)))

(define new-table  ; not defined in the book
  (lambda (entry)
    (extend-table entry empty-table)))

(define lookup-in-table
  (lambda (name table lookup-failure-proc)
    (cond
     [(null? table) (lookup-failure-proc name)]
     [else
      (lookup-in-entry name
                       (first table)
                       ;; fallback will be to look up the name in the rest of
                       ;; the table
                       (lambda (name)
                         (lookup-in-table name
                                          (rest table)
                                          ;; the failure proc is retained, to be
                                          ;; called when there are no more
                                          ;; entries to continue the lookup in
                                          lookup-failure-proc)))])))

;; ======================
;; EXPRESSIONS TO ACTIONS
;; ======================

;; An S-expression is either an atom or a list.

;; -> There are 2 cases to distinguish, when transforming an S-expression to an
;; action.

(define expression-to-action
  (lambda (expr)
    "Having to evaluate an expression, one first has to know what to do
next. This procedure delegates the decision what to do next to 2 procedures."
    (cond [(atom? expr) (atom-to-action expr)]
          [else (list-to-action expr)])))

(define atom-to-action
  (lambda (#|atom|# a)
    ;; An atom is always a constant or it is an identifier, which is bound to
    ;; something else, which we hopefully find inside a table/an environment.
    (cond [(number? a) *const]
          [(eq? a #t) *const]
          [(eq? a #f) *const]
          [(eq? a 'cons) *const]
          [(eq? a 'car) *const]
          [(eq? a 'cdr) *const]
          [(eq? a 'null?) *const]
          [(eq? a 'eq?) *const]
          [(eq? a 'atom?) *const]
          [(eq? a 'zero?) *const]
          [(eq? a 'add1) *const]
          [(eq? a 'sub1) *const]
          [(eq? a 'number?) *const]
          [else *identifier])))

(define list-to-action
  (lambda (#|list|# l)
    (cond [(atom? (car l))
           (cond [(eq? (car l) 'quote) *quote]
                 [(eq? (car l) 'lambda) *lambda]
                 [(eq? (car l) 'cond) *cond]
                 [else *application])]
          [else *application])))

;; =================
;; VALUE AND MEANING
;; =================

;; The procedure `meaning` approximates `eval`.

(define value
  (lambda (expr)
    "The procedure value evaluates an expression giving an empty environment."
    (meaning expr empty-table)))

(define meaning
  (lambda (expr table)
    "The procedure meaning evaluates an expression given an environment. It does
so by figuring out what the next action to take is and then applies that action
to the expression and the given environment."
    ((expression-to-action expr) expr table)))

;; =====================
;; DEFINITION OF ACTIONS
;; =====================

(define *const
  (lambda (expr table)
    "This interpreter does not deal with strings. There are only numbers,
booleans and primitive procedures and compositions of those."
    (cond
     [(number? expr) expr]
     [(eq? expr #t) #t]
     [(eq? expr #f) #f]
     [else
      (build 'primitive expr)])))

(define *quote
  (lambda (expr table)
    (text-of-quotation expr)))

;; Explanation: Something quoted has the form `'(quote something)`, so the second
;; part is the quoted thing. But why name it its "text"?

(define *identifier
  (lambda (expr table)
    "An identifier's meaning depends on the environment it is defined in, so we
look up its meaning there."
    (lookup-in-table expr
                     table
                     ;; Lookup in an empty table, which is the
                     ;; lookup-failure-proc, will result in an error.
                     lookup-in-empty-table)))

(define *lambda
  (lambda (the-lambda table)
    "This will result in something like the following:
(list 'non-primitive
      <table>
      <formals-of-lambda>
      <body-of-lambda>)"
    (build 'non-primitive
           (cons table
                 ;; The cdr of a lambda expression is its argument list and a
                 ;; body.
                 (cdr the-lambda)))))

(define *cond
  (lambda (cond-expr table)
    "Evaluating a cond expression is simple. One needs only to figure out which
of the questions or conditions is true, starting from the first of the
cond-cases. Once a true question or condition has been found one needs to
evaluate its answer or consequent, using the given environment or table."
    (evaluate-cond-q-and-a-lines (cond-q-and-a-lines-of cond-expr) table)))

(define *application
  (lambda (expr table)
    "An *application is always an application of a primitive (for example: car,
cdr, ...) or application of a user defined procedure, a non-primitive."
    ;; The idea here is to first evaluate the procedure and its arguments,
    ;; before applying the procedure to its arguments.
    (apply
     ;; We get the definition for the procedure out of the given environment.
     (meaning (function-of-applicable-expr expr) table)
     ;; Then we evaluate the arguments of the procedure call using the given
     ;; environment.
     (evaluate-list (arguments-of expr) table))))

;; =============================
;; DATA ABSTRACTIONS FOR ACTIONS
;; =============================

(define text-of-quotation second)
(define table-of first)
(define formals-of second)
(define body-of third)
(define question-of-cond-branch first)
(define answer-of-cond-branch second)
(define cond-q-and-a-lines-of cdr)
(define function-of-applicable-expr car)
(define arguments-of cdr)

(define else?
  (lambda (something)
    ;; The book includes a check for `atom?`. I am not sure why this is
    ;; necessary, if we already check whether `something` is equal to the symbol
    ;; `else`.
    (eq? something 'else)))

;; The book distinguishes between primitives and non-primitives as types of
;; functions, where primitives are the ones, which need to already be defined in
;; our language to construct non-primitives from them. The functions are marked
;; as primitives or non-primitives by putting a tag (a symbol) in an expression,
;; which represents a primitive or a non-primitive. It is tagged data.

;; We can see this being put in our implementation of *lambda and *const. In the
;; predicates `primitive?` and `non-primitive?` we look for those markers.

(define primitive?
  (lambda (sth)
    (eq? (first sth) 'primitive)))

(define non-primitive?
  (lambda (sth)
    (eq? (first sth) 'non-primitive)))

;; =====================
;; EVALUATION PROCEDURES
;; =====================

;; Writing a function for evaluating a cond expression. This can be done,
;; because we now have code that evaluates code and thus is one level above the
;; evaluated code. This is why we do only need a normal function to evaluate a
;; cond expression. A macro is basically the same thing as such one level above
;; code, because it processes the code and can perform syntax transformations
;; before the code is run.

;; Also note, that cond is not an *application. As the book continues to
;; explain, in an *application expression, all the arguments must be evaluated,
;; before the application can be done. This must not be the case for a cond
;; expression. Instead, only parts of it shall be evaluated.

(define evaluate-cond-q-and-a-lines
  (lambda (q-and-a-lines table)
    ;; When evaluating a cond expression, we in turn rely on cond in our
    ;; one-level-above language. This cond is not necessarily the same as the
    ;; cond in the code we are processing.
    (cond
     ;; Check for an else-branch. In this case evaluate the answer part.
     [(else? (question-of-cond-branch (car q-and-a-lines)))
      (meaning (answer-of-cond-branch (car q-and-a-lines))
               table)]
     ;; If there is a normal question, then it needs to be evaluated, to get its
     ;; boolean return value.
     [(meaning (question-of-cond-branch (car q-and-a-lines))
               table)
      (meaning (answer-of-cond-branch (car q-and-a-lines))
               table)]
     ;; Otherwise consider the next question answer pair.
     [else
      (evaluate-cond-q-and-a-lines (rest q-and-a-lines) table)])))

(define evaluate-list
  (lambda (list-expression table)
    ;; This will "reduce" the list elements (arguments), so that they are ready
    ;; to have the function applied to them.
    (cond
     ;; If the list is empty, then the result is also empty.
     [(null? list-expression) '()]
     [else
      (cons (meaning (car list-expression) table)
            (evaluate-list (cdr list-expression) table))])))

;; =====
;; APPLY
;; =====

;; What follows are the procedures that, with the help of the procedures defined
;; before, apply procedures and primitives to expressions in the limited lisp
;; dialect we built.

(define apply
  (lambda (func args)
    "apply receives the result of an evaluation of a procedure name, which is a "
    ;; Depending on whether a procedure is a primitive or a non-primitive, the
    ;; application happens in different ways.
    (cond
     [(primitive? func)
      ;; first of func is the tag for primitive or non-primitive.
      ;; '(primitive func-name args)
      (apply-primitive (second func) args)]
     [(non-primitive? func)
      (apply-closure (second func) args)]
     [else
      (throw 'wrong-call-to-apply func args)])))

;; Explanation: The whole time we were writing procedures to evaluate lists or
;; subsequently atoms, which represent programs. This `apply-primitive`
;; procedure is all about understanding, what kind of expression we have to
;; evaluate and then do the transformation, which leads to the evaluation result
;; in our one-level-above language. For example, if we find a `car`, then we
;; need to get the first element of the list that is in `vals`. This is what we
;; do in our one-level-above language. The result is returned as a value, which
;; is reinserted into the evaluated language's context.

(define apply-primitive
  (lambda (name vals)
    (define :atom?
      (lambda (sth)
        (cond
         [(atom? sth) #t]
         ;; Why have more cases? Isn't the check for atom? sufficient?  A: No,
         ;; we need to unwrap things. We tagged expressions with things like
         ;; 'primitive and 'non-primitive. Those could be atoms.
         [(null? sth) #f]
         ;; OK, primitives are countes as atoms then.
         [(eq? (car sth) 'primitive) #t]
         ;; Why #t?
         [(eq? (car sth) 'non-primitive) #t]
         [else #f])))
    (cond
     [(eq? name #| here was a gap |# 'cons)
      (cons (first vals) (second vals))]

     [(eq? name 'car)
      (car (first vals))]

     [(eq? name 'cdr)
      (#| here was a gap |# cdr (first vals))]

     [(eq? name 'null?)
      (null? (first vals))]

     [(eq? name 'eq?)
      (#| here was a gap |# eq? (first vals) #| here was a gap |# (second vals))]

     [(eq? name 'atom?)
      ;; Here we define the semantics of `atom?` in our evaluated language using
      ;; our meta language. Q: I don't know, why the semantics are different
      ;; from the ones we defined for `atom?` in our meta language. A: Now I
      ;; know: Because we need to unwrap for things we tagged as primitives, as
      ;; stated in the definition of `:atom?`.
      (#| here was a gap |# :atom? (first vals))]

     [(eq? name 'zero?)
      (zero? (first vals))]

     [(eq? name 'add1)
      (+ (first vals) 1)]

     [(eq? name 'sub1)
      (- (first vals) 1)]

     [(eq? name 'number?)
      (number? (first vals))])))

(define apply-closure
  (lambda (closure vals)
    ;; Evaluate the closure with the extended environment.
    (meaning
     (body-of closure)
     ;; Add the arguments of the closure to its table, to be able to use
     ;; `meaning` on the body of the closure and the extended table
     ;; (environment).
     (extend-table (new-entry (formals-of closure) vals)
                   (table-of closure)))))