PL: Lecture #17  Tuesday, November 1st
(text)

State and Environments

A quick example of how mutation can be used:

(define counter
  (let ([counter (box 0)])
    (lambda ()
      (set-box! counter (+ 1 (unbox counter)))
      (unbox counter))))

and compare that to:

(define (make-counter)
  (let ([counter (box 0)])
    (lambda ()
      (set-box! counter (+ 1 (unbox counter)))
      (unbox counter))))

It is a good idea if you follow the exact evaluation of

(define foo (make-counter))
(define bar (make-counter))

and see how both bindings have separate environment so each one gets its own private state. The equivalent code in the homework interpreter extended with set! doesn’t need boxes:

{with {make-counter
        {fun {}
          {with {counter 0}
            {fun {}
              {set! counter {+ counter 1}}
              counter}}}}
  {with {foo {call make-counter}}
    {with {bar {call make-counter}}
      ...}}}

To see multiple values from a single expression you can extend the language with a list binding. As a temporary hack, we can use dummy function inputs to cover for our lack of nullary functions, and use with (with dummy bound ids) to sequence multiple expressions:

{with {make-counter
        {fun {init}
          {with {counter init}
            {fun {_}
              {with {_ {set! counter {+ counter 1}}}
                counter}}}}}
  {with {foo {call make-counter 0}}
    {with {bar {call make-counter 1}}
      {+ {+ {call foo 0} {+ {* 10 {call foo 0}}
                            {* 100 {call foo 0}}}}
        {* 10000 {+ {call bar 0} {+ {* 10 {call bar 0}}
                                    {* 100 {call bar 0}}}}}}}}}

Note that we cannot describe this behavior with substitution rules! We now use the environments to make it possible to change bindings — so finally an environment is actually an environment rather than a substitution cache.

When you look at the above, note that we still use lexical scope — in fact, the local binding is actually a private state that nobody can access. For example, if we write this:

(define counter
  (let ([counter (box 0)])
    (lambda ()
      (set-box! counter (+ 1 (unbox counter)))
      (if (zero? (modulo (unbox counter) 4)) 'tock 'tick))))

then the resulting function that us bound to counter keeps a local integer state which no other code can access — you cannot modify it, reset it, or even know if it is really an integer that is used in there.

Implementing Objects with State

We have already seen how several pieces of information can be encapsulate in a Racket closure that keeps them all; now we can do a little more — we can actually have mutable state, which leads to a natural way to implement objects. For example:

(define (make-point x y)
  (let ([xb (box x)]
        [yb (box y)])
    (lambda (msg)
      (match msg
        ['getx (unbox xb)]
        ['gety (unbox yb)]
        ['incx (set-box! xb (add1 (unbox xb)))]))))

implements a constructor for point objects which keep two values and can move one of them. Note that the messages act as a form of methods, and that the values themselves are hidden and are accessible only through the interface that these messages make. For example, if these points correspond to some graphic object on the screen, we can easily incorporate a necessary screen update:

(define (make-point x y)
  (let ([xb (box x)]
        [yb (box y)])
    (lambda (msg)
      (match msg
        ['getx (unbox xb)]
        ['gety (unbox yb)]
        ['incx (set-box! xb (add1 (unbox xb)))
              (update-screen)]))))

and be sure that this is always done when the value changes — since there is no way to change the value except through this interface.

A more complete example would define functions that actually send these messages — here is a better implementation of a point object and the corresponding accessors and mutators:

(define (make-point x y)
  (let ([xb (box x)]
        [yb (box y)])
    (lambda (msg)
      (match msg
        ['getx (unbox xb)]
        ['gety (unbox yb)]
        [(list 'setx newx)
        (set-box! xb newx)
        (update-screen)]
        [(list 'sety newy)
        (set-box! yb newy)
        (update-screen)]))))
(define (point-x p) (p 'getx))
(define (point-y p) (p 'gety))
(define (set-point-x! p x) (p (list 'setx x)))
(define (set-point-y! p y) (p (list 'sety y)))

And a quick imitation of inheritance can be achieved using delegation to an instance of the super-class:

(define (make-colored-point x y color)
  (let ([p (make-point x y)])
    (lambda (msg)
      (match msg
        ['getcolor color]
        [else (p msg)]))))

You can see how all of these could come from some preprocessing of a more normal-looking class definition form, like:

(defclass point (x y)
  (public (getx) x)
  (public (gety) y)
  (public (setx new) (set! x newx))
  (public (setx new) (set! x newx)))

(defclass colored-point point (c)
  (public (getcolor) c))

The Toy Language

Not in PLAI

A quick note: from now on, we will work with a variation of our language — it will change the syntax to look a little more like Racket, and we will use Racket values for values in our language and Racket functions for built-ins in our language.

Main highlights:

The following is the complete implementation.

#lang pl

;;; ----------------------------------------------------------------
;;; Syntax

#| The BNF:
  <TOY> ::= <num>
          | <id>
          | { bind {{ <id> <TOY> } ... } <TOY> }
          | { fun { <id> ... } <TOY> }
          | { if <TOY> <TOY> <TOY> }
          | { <TOY> <TOY> ... }
|#

;; A matching abstract syntax tree datatype:
(define-type TOY
  [Num  Number]
  [Id  Symbol]
  [Bind (Listof Symbol) (Listof TOY) TOY]
  [Fun  (Listof Symbol) TOY]
  [Call TOY (Listof TOY)]
  [If  TOY TOY TOY])

(: unique-list? : (Listof Any) -> Boolean)
;; Tests whether a list is unique, guards Bind and Fun values.
(define (unique-list? xs)
  (or (null? xs)
      (and (not (member (first xs) (rest xs)))
          (unique-list? (rest xs)))))

(: parse-sexpr : Sexpr -> TOY)
;; parses s-expressions into TOYs
(define (parse-sexpr sexpr)
  (match sexpr
    [(number: n)    (Num n)]
    [(symbol: name) (Id name)]
    [(cons 'bind more)
    (match sexpr
      [(list 'bind (list (list (symbol: names) (sexpr: nameds))
                          ...)
          body)
        (if (unique-list? names)
          (Bind names (map parse-sexpr nameds) (parse-sexpr body))
          (error 'parse-sexpr "duplicate `bind' names: ~s" names))]
      [else (error 'parse-sexpr "bad `bind' syntax in ~s" sexpr)])]
    [(cons 'fun more)
    (match sexpr
      [(list 'fun (list (symbol: names) ...) body)
        (if (unique-list? names)
          (Fun names (parse-sexpr body))
          (error 'parse-sexpr "duplicate `fun' names: ~s" names))]
      [else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])]
    [(cons 'if more)
    (match sexpr
      [(list 'if cond then else)
        (If (parse-sexpr cond)
            (parse-sexpr then)
            (parse-sexpr else))]
      [else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
    [(list fun args ...) ; other lists are applications
    (Call (parse-sexpr fun)
          (map parse-sexpr args))]
    [else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))

(: parse : String -> TOY)
;; Parses a string containing an TOY expression to a TOY AST.
(define (parse str)
  (parse-sexpr (string->sexpr str)))

;;; ----------------------------------------------------------------
;;; Values and environments

(define-type ENV
  [EmptyEnv]
  [FrameEnv FRAME ENV])

;; a frame is an association list of names and values.
(define-type FRAME = (Listof (List Symbol VAL)))

(define-type VAL
  [RktV  Any]
  [FunV  (Listof Symbol) TOY ENV]
  [PrimV ((Listof VAL) -> VAL)])

(: extend : (Listof Symbol) (Listof VAL) ENV -> ENV)
;; extends an environment with a new frame.
(define (extend names values env)
  (if (= (length names) (length values))
    (FrameEnv (map (lambda ([name : Symbol] [val : VAL])
                    (list name val))
                  names values)
              env)
    (error 'extend "arity mismatch for names: ~s" names)))

(: lookup : Symbol ENV -> VAL)
;; lookup a symbol in an environment, frame by frame,
;; return its value or throw an error if it isn't bound
(define (lookup name env)
  (cases env
    [(EmptyEnv) (error 'lookup "no binding for ~s" name)]
    [(FrameEnv frame rest)
    (let ([cell (assq name frame)])
      (if cell
        (second cell)
        (lookup name rest)))]))

(: unwrap-rktv : VAL -> Any)
;; helper for `racket-func->prim-val': unwrap a RktV wrapper in
;; preparation to be sent to the primitive function
(define (unwrap-rktv x)
  (cases x
    [(RktV v) v]
    [else (error 'racket-func "bad input: ~s" x)]))

(: racket-func->prim-val : Function -> VAL)
;; converts a racket function to a primitive evaluator function
;; which is a PrimV holding a ((Listof VAL) -> VAL) function.
;; (the resulting function will use the list function as is,
;; and it is the list function's responsibility to throw an error
;; if it's given a bad number of arguments or bad input types.)
(define (racket-func->prim-val racket-func)
  (define list-func (make-untyped-list-function racket-func))
  (PrimV (lambda (args)
          (RktV (list-func (map unwrap-rktv args))))))

;; The global environment has a few primitives:
(: global-environment : ENV)
(define global-environment
  (FrameEnv (list (list '+ (racket-func->prim-val +))
                  (list '- (racket-func->prim-val -))
                  (list '* (racket-func->prim-val *))
                  (list '/ (racket-func->prim-val /))
                  (list '< (racket-func->prim-val <))
                  (list '> (racket-func->prim-val >))
                  (list '= (racket-func->prim-val =))
                  ;; values
                  (list 'true  (RktV #t))
                  (list 'false (RktV #f)))
            (EmptyEnv)))

;;; ----------------------------------------------------------------
;;; Evaluation

(: eval : TOY ENV -> VAL)
;; evaluates TOY expressions
(define (eval expr env)
  ;; convenient helper
  (: eval* : TOY -> VAL)
  (define (eval* expr) (eval expr env))
  (cases expr
    [(Num n)  (RktV n)]
    [(Id name) (lookup name env)]
    [(Bind names exprs bound-body)
    (eval bound-body (extend names (map eval* exprs) env))]
    [(Fun names bound-body)
    (FunV names bound-body env)]
    [(Call fun-expr arg-exprs)
    (let ([fval (eval* fun-expr)]
          [arg-vals (map eval* arg-exprs)])
      (cases fval
        [(PrimV proc) (proc arg-vals)]
        [(FunV names body fun-env)
          (eval body (extend names arg-vals fun-env))]
        [else (error 'eval "function call with a non-function: ~s"
                      fval)]))]
    [(If cond-expr then-expr else-expr)
    (eval* (if (cases (eval* cond-expr)
                  [(RktV v) v] ; Racket value => use as boolean
                  [else #t])  ; other values are always true
              then-expr
              else-expr))]))

(: run : String -> Any)
;; evaluate a TOY program contained in a string
(define (run str)
  (let ([result (eval (parse str) global-environment)])
    (cases result
      [(RktV v) v]
      [else (error 'run "evaluation returned a bad value: ~s"
                  result)])))

;;; ----------------------------------------------------------------
;;; Tests

(test (run "{{fun {x} {+ x 1}} 4}")
      => 5)
(test (run "{bind {{add3 {fun {x} {+ x 3}}}} {add3 1}}")
      => 4)
(test (run "{bind {{add3 {fun {x} {+ x 3}}}
                  {add1 {fun {x} {+ x 1}}}}
              {bind {{x 3}} {add1 {add3 x}}}}")
      => 7)
(test (run "{bind {{identity {fun {x} x}}
                  {foo {fun {x} {+ x 1}}}}
              {{identity foo} 123}}")
      => 124)
(test (run "{bind {{x 3}}
              {bind {{f {fun {y} {+ x y}}}}
                {bind {{x 5}}
                  {f 4}}}}")
      => 7)
(test (run "{{{fun {x} {x 1}}
              {fun {x} {fun {y} {+ x y}}}}
            123}")
      => 124)

;; More tests for complete coverage
(test (run "{bind x 5 x}")      =error> "bad `bind' syntax")
(test (run "{fun x x}")        =error> "bad `fun' syntax")
(test (run "{if x}")            =error> "bad `if' syntax")
(test (run "{}")                =error> "bad syntax")
(test (run "{bind {{x 5} {x 5}} x}") =error> "duplicate*bind*names")
(test (run "{fun {x x} x}")    =error> "duplicate*fun*names")
(test (run "{+ x 1}")          =error> "no binding for")
(test (run "{+ 1 {fun {x} x}}") =error> "bad input")
(test (run "{+ 1 {fun {x} x}}") =error> "bad input")
(test (run "{1 2}")            =error> "with a non-function")
(test (run "{{fun {x} x}}")    =error> "arity mismatch")
(test (run "{if {< 4 5} 6 7}")  => 6)
(test (run "{if {< 5 4} 6 7}")  => 7)
(test (run "{if + 6 7}")        => 6)
(test (run "{fun {x} x}")      =error> "returned a bad value")

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