enforced-state-machine.rkt

#lang racket
;; Use Racket 7.3 or later; in particular, 7.0.0.7 seems to have a bug
;; where call-with-immediate-continuation-mark seems to dig past the
;; first continuation frame when it isn't supposed to.

(module+ test (require rackunit))

(module state-machine racket
  (provide state-machine
           state-lambda
           define-state)

  (define-syntax (state-machine stx)
    (syntax-case stx ()
      [(_  key-expr body0 body ...)
       (syntax/loc stx
         (with-continuation-mark key-expr #t
           (begin body0 body ...)))]))

  (define-syntax (state-lambda* stx)
    (syntax-case stx ()
      [(_ function-name key-expr argspec body0 body ...)
       (syntax/loc #'body0
         (lambda argspec
           (call-with-immediate-continuation-mark
            key-expr
            (lambda (at-state-machine-top?)
              (when (not at-state-machine-top?)
                (error function-name
                       "Invocation of state function with non-empty continuation"))
              (begin body0 body ...))
            #f)))]))

  (define-syntax (state-lambda stx)
    (syntax-case stx ()
      [(_ key-expr argspec body0 body ...)
       (syntax/loc stx
         (state-lambda* '<unknown> key-expr argspec body0 body ...))]))

  (define-syntax (define-state stx)
    (syntax-case stx ()
      [(_ key-expr (f . argspec) body0 body ...)
       (syntax/loc stx
         (define f (state-lambda* 'f key-expr argspec body0 body ...)))])))

(module+ test
  (let ((key 'key))
    (local-require (submod ".." state-machine))
    (check-equal? (state-machine key 1) 1)

    (define-state key (A revacc tokens)
      (match tokens
        ['() (reverse revacc)]
        [(cons 'X more) (cons 'X (A revacc more))]
        [(cons other more) (A (cons other revacc) more)]))

    (check-equal? (state-machine key (A '() '(a b c d e f))) '(a b c d e f))
    (check-exn #px"Invocation of state function with non-empty continuation"
               (lambda () (state-machine key (A '() '(a b c X d e f))) '(a b c d e f)))))

(module reflectable-closure racket
  (provide rlambda
           ensure-rlambda!
           (rename-out [rlambda-base? rlambda?]))

  (struct rlambda-base () #:transparent)

  (define-syntax (rlambda stx)
    (syntax-case stx ()
      [(_ label [free-var ...] argspec body0 body ...)
       (with-syntax [(f (syntax-local-lift-expression
                         #'(let ()
                             (struct label rlambda-base (free-var ...) #:transparent
                               #:property prop:procedure
                               (lambda (inst . argspec)
                                 (match-define (label free-var ...) inst)
                                 (begin body0 body ...)))
                             label)))]
         #'(f free-var ...))]))

  (define (ensure-rlambda! who v)
    (when (not (rlambda-base? v))
      (error who "Not an rlambda: ~v" v))))

(module+ test
  (require (submod ".." reflectable-closure))
  (let ()
    (define (ADD x)
      (rlambda ADD-clo [x] (y)
               (+ x y)))
    ;; (println (ADD 1))
    ;; (println (rlambda? (ADD 2)))
    ;; (println (ADD 3))
    ;; (println (rlambda? ((lambda (x) (lambda (y) (+ x y))) 2)))
    (check-equal? ((ADD 1) 2) 3)))

;;---------------------------------------------------------------------------

(module runtime racket
  (provide (all-defined-out))

  (struct closure (vars expr env) #:prefab)

  (struct env (bindings))

  (define (bound? v ρ) (hash-has-key? (env-bindings ρ) v))
  (define (unbound? v ρ) (not (bound? v ρ)))

  (define (empty-env) (env (hash)))
  (define (env-extend ρ k v) (env (hash-set (env-bindings ρ) k v)))
  (define (env-ref ρ k) (hash-ref (env-bindings ρ) k)))

(module+ test
  (require (submod ".." runtime))
  (define (check-interpreter eval)
    (check-equal? (eval `(+ 1 2 3) (empty-env)) 6)
    (check-equal? (eval `((lambda (x y) (+ x y 3)) 1 2) (empty-env)) 6)

    (define uncurried-Z-term `(lambda (f)
                                (lambda (w)
                                  ((lambda (x w) (f (lambda (v) (x x v)) w))
                                   (lambda (x w) (f (lambda (v) (x x v)) w))
                                   w))))

    (check-equal? (eval `((lambda (length)
                            (length '(a b c d)))
                          (,uncurried-Z-term (lambda (length x)
                                               (if (null? x)
                                                   0
                                                   (+ 1 (length (cdr x)))))))
                        (empty-env))
                  4)

    (check-equal? (eval `((lambda (fib)
                            (fib 5))
                          (,uncurried-Z-term (lambda (fib n)
                                               (if (< n 2)
                                                   n
                                                   (+ (fib (- n 1))
                                                      (fib (- n 2)))))))
                        (empty-env))
                  5))
  )

(module plain-interpreter racket
  (provide eval)
  (require (submod ".." runtime))

  (define-syntax-rule (delta (operator-expr operands env) [prim ...] clause ...)
    (match operator-expr
      ['prim #:when (unbound? 'prim env) (apply prim operands)] ...
      clause ...))

  (define (eval expr env)
    (match expr
      [(? symbol? var)
       (env-ref env var)]
      [x #:when (not (pair? x))
         x]
      [`(lambda (,@vars) ,@exprs) #:when (unbound? 'lambda env)
       (closure vars `(begin ,@exprs) env)]
      [`(begin) #:when (unbound? 'begin env)
       (void)]
      [`(begin ,expr) #:when (unbound? 'begin env)
       (eval expr env)]
      [`(begin ,expr ,@exprs) #:when (unbound? 'begin env)
       (eval expr env)
       (eval `(begin ,@exprs) env)]
      [`(if ,test ,true ,false) #:when (unbound? 'if env)
       (if (eval test env)
           (eval true env)
           (eval false env))]
      [`(quote ,x) #:when (unbound? 'quote env)
       x]
      [`(,operator-expr ,@operand-exprs)
       (let ((operands (eval-args operand-exprs env)))
         (delta (operator-expr operands env)
                [+ - * / = < cons car cdr null? pair?]
                [other-expr
                 (match (eval other-expr env)
                   [(closure cl-vars cl-expr cl-env)
                    (define new-env (for/fold [(new-env cl-env)]
                                              [(k cl-vars) (v operands)]
                                      (env-extend new-env k v)))
                    (eval cl-expr new-env)])]))]))

  (define (eval-args operand-exprs env)
    (map (lambda (e) (eval e env)) operand-exprs)))

(module state-interpreter/0 racket
  (provide (rename-out [outer-eval eval]))
  (require (submod ".." runtime))
  (require (submod ".." state-machine))

  (define key 'state)

  (define-syntax-rule (delta (operator-expr operands env) [prim ...] clause ...)
    (match operator-expr
      ['prim #:when (unbound? 'prim env) (apply prim operands)] ...
      clause ...))

  (define-state key (eval expr env)
    (match expr
      [(? symbol? var)
       (env-ref env var)]
      [x #:when (not (pair? x))
         x]
      [`(lambda (,@vars) ,@exprs) #:when (unbound? 'lambda env)
       (closure vars `(begin ,@exprs) env)]
      [`(begin) #:when (unbound? 'begin env)
       (void)]
      [`(begin ,expr) #:when (unbound? 'begin env)
       (eval expr env)]
      [`(begin ,expr ,@exprs) #:when (unbound? 'begin env)
       (eval expr env)
       (eval `(begin ,@exprs) env)]
      [`(if ,test ,true ,false) #:when (unbound? 'if env)
       (if (eval test env)
           (eval true env)
           (eval false env))]
      [`(quote ,x) #:when (unbound? 'quote env)
       x]
      [`(,operator-expr ,@operand-exprs)
       (let ((operands (eval-args operand-exprs env)))
         (delta (operator-expr operands env)
                [+ - * / = < cons car cdr null? pair?]
                [other-expr
                 (match (eval other-expr env)
                   [(closure cl-vars cl-expr cl-env)
                    (define new-env (for/fold [(new-env cl-env)]
                                              [(k cl-vars) (v operands)]
                                      (env-extend new-env k v)))
                    (eval cl-expr new-env)])]))]))

  (define-state key (eval-args operand-exprs env)
    (map (lambda (e) (eval e env)) operand-exprs))

  (define (outer-eval expr env)
    (state-machine key (eval expr env))))

(module state-interpreter/1 racket
  (provide (rename-out [outer-eval eval]))
  (require (submod ".." runtime))
  (require (submod ".." state-machine))
  (require (submod ".." reflectable-closure))

  (define key 'state)

  (define-syntax-rule (delta (operator-expr operands env k) [prim ...] clause ...)
    (match operator-expr
      ['prim #:when (unbound? 'prim env) (k (apply prim operands))] ...
      clause ...))

  (define-state key (eval expr env k)
    (match expr
      [(? symbol? var)
       (k (env-ref env var))]
      [x #:when (not (pair? x))
       (k x)]
      [`(lambda (,@vars) ,@exprs) #:when (unbound? 'lambda env)
       (k (closure vars `(begin ,@exprs) env))]
      [`(begin) #:when (unbound? 'begin env)
       (k (void))]
      [`(begin ,expr) #:when (unbound? 'begin env)
       (eval expr env k)]
      [`(begin ,expr ,@exprs) #:when (unbound? 'begin env)
       (eval expr env (lambda (_v) (eval `(begin ,@exprs) env k)))]
      [`(if ,test ,true ,false) #:when (unbound? 'if env)
       (eval test env (lambda (v)
                        (if v
                            (eval true env k)
                            (eval false env k))))]
      [`(quote ,x) #:when (unbound? 'quote env)
       (k x)]
      [`(,operator-expr ,@operand-exprs)
       (eval-args operand-exprs env '()
                  (lambda (operands)
                    (delta (operator-expr operands env k)
                           [+ - * / = < cons car cdr null? pair?]
                           [other-expr
                            (eval other-expr env
                                  (match-lambda
                                    [(closure cl-vars cl-expr cl-env)
                                     (define new-env (for/fold [(new-env cl-env)]
                                                               [(k cl-vars) (v operands)]
                                                       (env-extend new-env k v)))
                                     (eval cl-expr new-env k)]))])))]))

  (define-state key (eval-args operand-exprs env revacc k)
    (match operand-exprs
      [(cons e more)
       (eval e env (lambda (v) (eval-args more env (cons v revacc) k)))]
      ['()
       (k (reverse revacc))]))

  (define (outer-eval expr env)
    (state-machine key (eval expr env (lambda (result) result)))))

(module state-interpreter/2 racket
  (provide (rename-out [outer-eval eval]))
  (require (submod ".." runtime))
  (require (submod ".." state-machine))
  (require (submod ".." reflectable-closure))

  (define key 'state)

  (define-syntax-rule (delta (operator-expr operands env k) [prim ...] clause ...)
    (match operator-expr
      ['prim #:when (unbound? 'prim env) (k (apply prim operands))] ...
      clause ...))

  (define-state key (eval expr env k)
    (ensure-rlambda! 'eval k)
    ;; (pretty-print k)
    (match expr
      [(? symbol? var)
       (k (env-ref env var))]
      [x #:when (not (pair? x))
       (k x)]
      [`(lambda (,@vars) ,@exprs) #:when (unbound? 'lambda env)
       (k (closure vars `(begin ,@exprs) env))]
      [`(begin) #:when (unbound? 'begin env)
       (k (void))]
      [`(begin ,expr) #:when (unbound? 'begin env)
       (eval expr env k)]
      [`(begin ,expr ,@exprs) #:when (unbound? 'begin env)
       (eval expr env (lambda (_v) (eval `(begin ,@exprs) env k)))]
      [`(if ,test ,true ,false) #:when (unbound? 'if env)
       (eval test env (rlambda if-test [true false env k] (v)
                               (if v
                                   (eval true env k)
                                   (eval false env k))))]
      [`(quote ,x) #:when (unbound? 'quote env)
       (k x)]
      [`(,operator-expr ,@operand-exprs)
       (eval-args operand-exprs env '()
                  (rlambda dispatch-rator [operator-expr env k] (operands)
                    (delta (operator-expr operands env k)
                           [+ - * / = < cons car cdr null? pair?]
                           [other-expr
                            (eval other-expr env
                                  (rlambda evrator [operands k] (operator)
                                           (match-define (closure cl-vars cl-expr cl-env) operator)
                                           (define new-env (for/fold [(new-env cl-env)]
                                                                     [(k cl-vars) (v operands)]
                                                             (env-extend new-env k v)))
                                           (eval cl-expr new-env k)))])))]))

  (define-state key (eval-args operand-exprs env revacc k)
    (ensure-rlambda! 'eval-args k)
    (match operand-exprs
      [(cons e more)
       (eval e env
             (rlambda evrands [more env revacc k] (v) (eval-args more env (cons v revacc) k)))]
      ['()
       (k (reverse revacc))]))

  (define (outer-eval expr env)
    (state-machine key (eval expr env (rlambda outer [] (result) result)))))

(module+ test
  (define-syntax-rule (module-value mod expr)
    (let ()
      (printf "~a\n" 'mod)
      (local-require mod)
      expr))

  (check-interpreter (module-value (submod ".." plain-interpreter) eval))
  (check-exn #px"Invocation of state function with non-empty continuation"
             (lambda ()
               (check-interpreter (module-value (submod ".." state-interpreter/0) eval))))
  (check-interpreter (module-value (submod ".." state-interpreter/1) eval))
  (check-interpreter (module-value (submod ".." state-interpreter/2) eval))
  )