CC Machine in Scheme

#|                                                              -*- Scheme -*-
   [email protected]
   Released under the terms of the GNU Lesser General Public License.

   The CC Machine -- an ISWIM interpreter

   The specification of this eval-cc function comes from Felleisen & Flatt --
   Programming Languages and Lambda Calculi.

   See http://www.cs.uvm.edu/~dvanhorn/ocaml/cc.ml for an OCaml version of
   this machine.
|#

(require (lib "match.ss"))

;;   span : ('a -> bool) * 'a list -> ('a list 'a list)

;;   Span splits the list into the longest initial prefix whose elements all
;;   satisfy the predicate f, and the remaining tail. Cf. SRFI-1.

(define (span f ls)
  (letrec ((recur (match-lambda
                    [() '(() ())]
                    [(x . rest)
                     (if (f x)
                         (match-let ([(prefix suffix) (recur rest)])
                           (list (cons x prefix) suffix))
                         (list '() (cons x rest)))])))
    (recur ls)))


;;   delta : primop * term list -> term

(define (delta op args)
  (match args
    [(('value ('base ('int x))) . rest)
     (let* ((y
             (match rest
               [(('value ('base ('int y)))) y]
               [() 1]))
            (result
             (match op
               [(or 'add1  'plus) (+ x y)]
               [(or 'sub1 'minus)
                (let ((sum (- x y)))
                  (if (<= sum 0) 0 sum))])))
       `(value (base (int ,result))))]))

(define value?
  (match-lambda
    [('value v) #t]
    [_  #f]))

(define base?
  (match-lambda
    [('value ('base b)) #t]
    [_ #f]))


;;   gen-var : unit -> string

;;   Returns a fresh variable name of the form "zn" where n is an integer
;;   (so don't use variables of this form!).

(define gen-var
  (let ((i 0))
    (lambda ()
      (set! i (add1 i))
      (string-append "z" (number->string i)))))


;;   substitute : term * var * value -> term

;;   Substitutes v for x in m.

(define (substitute m x v)
  (match m
    [('value ('base b)) `(value (base ,b))]
    [('value ('var y))
     (if (equal? x y)
         `(value ,v)
         `(value (var ,y)))]
    [('value ('lambda (y n)))
     (if (equal? x y)
         `(value (lambda (,y ,n)))
         (let ((z (gen-var)))
           `(value (lambda (,z
                            ,(substitute (substitute n y `(var ,z)) x v))))))]
    [('app (n p))
     `(app ,(substitute n x v) ,(substitute p x v))]
    [('app-prim (o tlist))
     `(app-prim (,o ,(map (lambda (t) (substitute t x v)) tlist)))]))

;;   cc : (term context) -> (term context)

;;   The machine state transition function.

(define cc
  (match-lambda
    [(('app m n) e)
     (=> fail)
     (when (value? m) (fail))
     `(,m (c-in-hole ,e (c-app-e c-empty-hole ,n)))]
    [(('app ('value v) m) e)
     (=> fail)
     (when (value? m) (fail))
     `(,m (c-in-hole ,e (c-app-v ,v c-empty-hole)))]
    [(('app-prim o . args) e)
     (=> fail)
     (unless (andmap base? args) (fail))
     `(,(delta o args) ,e)]
    [(('app-prim o . args) e)
     (match-let (((vlist (m . tlist)) (span value? args)))
       (let ((vlist (map (match-lambda [('value v) v]) vlist)))
         `(,m (c-in-hole ,e (c-app-prim ,o ,vlist c-empty-hole ,tlist)))))]
    [(('app ('value ('lambda x m)) ('value v)) e)
     `(,(substitute m x v) ,e)]
    [(('value v) ('c-in-hole e ('c-app-v u 'c-empty-hole)))
     `((app (value ,u) (value ,v)) ,e)]
    [(('value v) ('c-in-hole e ('c-app-e 'c-empty-hole n)))
     `((app (value ,v) ,n) ,e)]
    [(('value v) ('c-in-hole e ('c-app-prim o vlist 'c-empty-hole tlist)))
     (let ((vlist (map (lambda (x) `(value ,x)) vlist)))
       `((app-prim ,o ,@vlist (value ,v) ,@tlist) ,e))]))

;;   eval-cc : term -> result

(define (eval-cc term)
  (letrec ((loop (match-lambda
                   [(('value ('base b)) 'c-empty-hole)
                    `(result ,b)]
                   [(('value ('lambda x m)) 'c-empty-hole) 'function]
                   [(term context) (loop (cc `(,term ,context)))])))
    (loop `(,term c-empty-hole))))


;;    ((lambda (x) x) ((lambda (x) x) 5)) -eval-cc-> (result (int 5))

(eval-cc '(app (value (lambda "x" (value (var "x"))))
               (app (value (lambda "x" (value (var "x"))))
                    (value (base (int 5))))))

;; -> (result (int 5))