sara/runtime.rkt

#lang racket/base
(provide
 value?
 basic-value?
 primitive-procedure? gen:primitive-procedure
 simple-primitive-proc define-primitive-procs
 prim:+ prim:- prim:* prim:/

 stack-frame?
 evaluate1
 evaluate*
 apply-procedure

 binding? make-bindings binding-name binding-def
 current-store store-ref store-init! store-set!

 structure? make-structure structure-add-bindings!
 instantiate-binding!
 instantiate-structure!)

(require
 racket/generic
 racket/match
 (only-in racket/string string-join)
 (only-in racket/format ~a ~s)
 (only-in racket/promise delay force)
 syntax/parse/define
 (for-syntax racket/base racket/syntax))


;; VALUES
;; v    = bv | prim
;; bv   = integer | string
;; prim = {primitive-procedure}

(define (basic-value? x)
  (or (exact-integer? x)
      (string? x)))

(define (value? x)
  (or (basic-value? x)
      (primitive-procedure? x)))

(define-generics primitive-procedure
  ;; prim [listof v] -> v
  (primitive-apply primitive-procedure args))

;; symbol [v ... -> v] -> prim
(struct simple-primitive-proc [name func]
  #:methods gen:primitive-procedure
  [(define (primitive-apply sp args)
     (apply (simple-primitive-proc-func sp) args))]
  #:methods gen:custom-write
  [(define (write-proc sp port _mode)
     (fprintf port "{prim:~a}" (simple-primitive-proc-name sp)))])

;; (define-primitive-procs id ...)
;; For each "id", defines "prim:id" to be a primitive-proc that calls function "id".
(define-simple-macro (define-primitive-procs f ...)
  #:with [f* ...] (map (λ (x) (format-id x "prim:~a" x)) (attribute f))
  (begin (define f* (simple-primitive-proc 'f f))
         ...))

(define-primitive-procs
  + - * /)


;; ================================================

;; EXPRESSIONS
;; e = bv                literal value
;;   | prim              primitive func
;;   | `(top B sym)      toplevel binding
;;   | `($ e e ...)      application

;; STACK FRAMES
;; s  = (sf ...)
;; sf = ($ v ... □ e ...)

(define (stack-frame? x)
  (sf:apply? x))

(struct sf:apply [left right]
  #:methods gen:custom-write
  [(define (write-proc sf port _unused)
     (match-define (sf:apply vs es) sf)
     (fprintf port "~s" `($ ,@(reverse vs) □ ,@es)))])

; stop/continue = (continue s e)
;               | (stop v)
(struct continue [stack redex])
(struct stop [value])


;; Evaluate expression until it reaches a value.
;; e -> v
(define (evaluate* e)
  (let loop ([s '[]] [e e])
    (match (evaluate1 s e)
      [(stop v) v]
      [(continue s* e*) (loop s* e*)])))

;; Take a single step in evaluating expression 'e' with stack 's'.
;; s e -> stop/continue
(define (evaluate1 s e)
  (match e
    [(? value?)
     (pop s e)]

    ;; {Σ;s | (top B)} ⇒ {Σ;s | Σ[B]}
    [`(top ,B ,name)
     (pop s
          (store-ref B
                     #:default
                     (λ () (error (~a "undefined: " name)))))]

    ; {s | ($ e1 e2 ...)} ⇒ {s ($ □ e2 ...) | e1}
    [`($ ,e1 ,e2s ...)
     (continue (cons (sf:apply '() e2s) s)
               e1)]))

;; Advance the top of stack 's' by applying the value 'v0'.
;; s v -> stop/continue
(define (pop s v0)
  (match s
    ['()
     (stop v0)]

    [(cons (sf:apply vs es) s*)
     (match es
       ; {($ f v ... □) | v0} ⇒ apply f(v ... v0)
       ['()
        (match-define (cons f args)
          (reverse (cons v0 vs)))
        (apply-procedure s* f args)]

       ; {($ v1 ... □ e1 e2 ...) | v0} ⇒ {($ v1 ... v0 □ e2 ...) | e1}
       [(cons e1 e2s)
        (continue (cons (sf:apply (cons v0 vs) e2s) s*)
                  e1)])]))

;; Apply arguments 'vs' to procedure value 'fun'.
;; RAISES: exn:fail - if 'fun' cannot be applied
;; s v [listof v] -> stop/continue
(define (apply-procedure s fun vs)
  (match fun
    [(? primitive-procedure? prim)
     (continue s
               (primitive-apply prim vs))]

    [_ (error "not an applicable value: ~s" fun)]))


(module+ test
  (require rackunit)
  (check-equal? (evaluate* `($ ,prim:+ 1 ($ ,prim:* ($ ,prim:- 4 1) 5)))
                (+ 1 (* (- 4 1) 5))))


;; ================================================

;; BINDINGS, STORES
;; Σ   = ([B v] ...)
;; B   = (x def)
;; def = `(val e)

;; [hasheq B => v]
(define current-store
  (make-parameter (hasheq)))

;; (binding symbol [lazy def])
(struct binding [name def/lz]
  #:methods gen:custom-write
  [(define (write-proc B port _)
     (cond [(print-hide-binding-rhs)
            (fprintf port
                     "{binding:~a}"
                     (binding-name B))]
           [else
            (parameterize ([print-hide-binding-rhs #t])
              (fprintf port
                       "{binding:~a=~s}"
                       (binding-name B)
                       (binding-def B)))]))])

(define print-hide-binding-rhs
  (make-parameter #f))


;; binding -> def
(define (binding-def b)
  (force (binding-def/lz b)))

;; Create bindings for each given symbol. Uses the given function to create the 'def' parts
;; of each binding. The function should return a def corresponding to each binding. The bindings
;; given to to the function are also returned.
;; [listof symbol] [[listof B] -> [listof def]] -> [listof B]
(define (make-bindings names mk-defs)
  (define bindings
    (for/list ([x (in-list names)]
               [i (in-naturals)])
      (binding x
               (delay (vector-ref defs i)))))
  (define defs
    (list->vector
     (mk-defs bindings)))
  bindings)

;; Generate possibly-recursive bindings (as in the struct) and bind them to given names (as in
;; racket variablebindings).
;;
;; (with-bindings ([id maybe-name def-expr] ...)
;;    body ...)
;;
;; maybe-name =
;;            | name-expr
;;
(define-simple-macro (with-bindings ([B:id {~optional {~seq name:expr} #:defaults ([name #''B])}
                                           def:expr]
                                     ...)
                       body ...+)
  (match-let ([(list B ...)
               (make-bindings (list name ...)
                              (match-lambda
                                [(list B ...)
                                 (list def ...)]))])
    body ...))

;; B        -> value
;; B [-> X] -> (or value X)
(define (store-ref B #:default [dft (λ ()
                                      (error (~a "undefined: "
                                                 (binding-name B))))])
  (hash-ref (current-store)
            B
            (λ () (dft))))

;; B v -> void
(define (store-init! B v)
  (hash-set! (current-store) B v))

;; B v -> void
(define (store-set! B v
                    #:ok [ok void]
                    #:error [err (λ ()
                                   (error (~a "undefined: "
                                              (binding-name B))))])
  (cond
    [(hash-has-key? (current-store) B)
     (hash-ref (current-store) B)
     (ok)]
    [else
     (err)]))


(module+ test
  (match-define (list B-x B-y)
    (make-bindings '[x y]
                   (match-lambda
                     [(list b1 b2)
                      (list `(val 3)
                            `(val (,prim:+ (top ,b1 x) 1)))])))

  (check-equal? (binding-name B-x) 'x)
  (check-equal? (binding-name B-y) 'y)
  (check-equal? (binding-def B-x) '(val 3))
  (check-match (binding-def B-y)
               `(val (,pls (top ,b x) 1))
               (and (eq? pls prim:+)
                    (eq? b B-x))))


;; ================================================

;; STRUCTURES
;; S = (B ...)

;; (structure [listof binding])
(struct structure
  [bindings] #:mutable)

;; Create a new empty structure.
;; -> S
(define (make-structure)
  (structure '[]))

;; Add the list of bindings to the structure.
;; S [listof B] -> void
(define (structure-add-bindings! S Bs)
  (set-structure-bindings! S (append (reverse Bs)
                                     (structure-bindings S))))

;; S B ... -> void
(define (structure-add-bindings*! S . Bs)
  (structure-add-bindings! S Bs))

;; Evaluate a binding, adding its value to the store.
;; B -> void
(define (instantiate-binding! B)
  (define v
    (match (binding-def B)
      [`(val ,e)
       (evaluate* e)]))
  (store-init! B v))

;; S -> void
(define (instantiate-structure! S)
  (for-each instantiate-binding!
            (reverse (structure-bindings S))))


(module+ test

  (define-simple-macro (with-structure S:id ([x:id . stuff] ...) body ...+)
    (let ([S (make-structure)])
      (with-bindings ([x . stuff] ...)
        (structure-add-bindings*! S x ...)
        body ...)))

  (define-simple-macro (with-empty-store Σ:id body ...+)
    (let ([Σ (make-hasheq)])
      (parameterize ([current-store Σ])
        body ...)))

  (with-structure S ([x `(val 3)]
                     [y `(val ($ ,prim:+ 2 3))]
                     [z `(val ($ ,prim:* (top ,x x) (top ,y y)))])
    (with-empty-store Σ
      (instantiate-structure! S)
      (check-equal? (store-ref x) 3)
      (check-equal? (store-ref y) 5)
      (check-equal? (store-ref z) 15)

      (check-true (hash-has-key? Σ x))
      (check-true (hash-has-key? Σ y))
      (check-true (hash-has-key? Σ z)))))