rgm

;; Explicit control evaluator from SICP 5.4

;; required "machine" operations from underlying Scheme
(define eceval-operations
  (list (list 'self-evaluating? self-evaluating)
        (list 'variable? variable)
        ;... etc
        ;self-evaluating?
        ;variable?
        ;quoted?

rgm

(define (fib n)
  (if (< n 2)
    n
    (+ (fib (- n 1)) (fib (- n 2)))))

;; becomes

(controller
    (assign continue (label fib-done))
  fib-loop

rgm

;; SICP 4.4 Query Interpreter
;; http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-29.html#%_sec_4.4
;; scheme -load logic.scm

;; ==================================================
;; 0 table data structure, see 3.3.3
;; ==================================================

(define (make-table)
  (let ((local-table (list '*table*)))

rgm

diff --git a/nondeterministic.scm b/nondeterministic.scm
index 1fab899..52e5b73 100644
--- a/nondeterministic.scm
+++ b/nondeterministic.scm
@@ -1,5 +1,5 @@
-(define (eval exp env)
-  ((analyze exp) env))
+(define (eval exp env succeed fail)
+  ((analyze exp) env succeed fail))
 

rgm

(define (eval exp env succeed fail)
  ((analyze exp) env succeed fail))

(define (analyze exp)
  (cond ((self-evaluating? exp) (analyze-self-evaluating exp))
        ((variable? exp) (analyze-variable exp))
        ((quoted? exp) (analyze-quoted exp))
        ((assignment? exp) (analyze-assignment exp))
        ((definition? exp) (analyze-definition exp))
        ((if? exp) (analyze-if exp))

rgm

diff --git a/metacircular.scm b/metacircular.scm
index 20542d1..97632e5 100644
--- a/metacircular.scm
+++ b/metacircular.scm
@@ -10,26 +10,43 @@
                                        env))
         ((begin? exp) (eval-sequence (begin-actions exp) env))
         ((cond? exp) (eval (cond->if exp) env))
-        ((application? exp) (apply (eval (operator exp) env)
-                                   (list-of-values (operands exp) env)))

rgm

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((assignment? exp) (eval-assignment exp env))
        ((definition? exp) (eval-definition exp env))
        ((if? exp) (eval-if exp env))
        ((lambda? exp) (make-procedure (lambda-parameters exp)
                                       (lambda-body exp)
                                       env))

rgm

;; SICP 3.3.4 - Constraint system

(define (for-each-except exception procedure list)
  (define (loop items)
    (cond ((null? items) 'done)
	  ((eq? (car items) exception) (loop (cdr items)))
	  (else (procedure (car items))
		(loop (cdr items)))))
  (loop list))

rgm

;; pure smoke immutable cons

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

(define car
  (lambda (x)
    (x (lambda (a d) a))))

rgm

(define (has-cycle? ls)
  (define (has-cycle-h tortoise hare)
    (cond ((null? hare) #f)
          ((null? (cdr hare)) #f)
          ((eq? (car tortoise) (car hare)) #t)
          (else
           (has-cycle-h (cdr tortoise) (cddr hare)))))
  (cond ((null? ls) #f)
        (else (has-cycle-h ls (cdr ls)))))