#lang racket
(module+ test
(require [only-in plait test test/exn print-only-errors ....])
)
(module param-mod plait
(define-type-alias ParamEnv (Hashof Symbol ParamValue))
(define-type ParamValue
[numV (n : Number)]
[funV (var : Symbol) (body : ParamExp) (env : ParamEnv)])
(define mt-env (hash empty)) ;; "empty environment"
(define (lookup (s : Symbol) (n : ParamEnv))
(type-case (Optionof ParamValue) (hash-ref n s)
[(none) (error s "not bound")]
[(some v) v]))
(define (extend old-env new-name value)
(hash-set old-env new-name value))
(define-type ParamExp
[varE (name : Symbol)]
[numE (n : Number)]
[let1E (var : Symbol) (exp : ParamExp) (body : ParamExp)]
[param1E (var : Symbol) (exp : ParamExp) (body : ParamExp)]
[paramRefE (var : Symbol)]
[appE (f : ParamExp) (a : ParamExp)]
[lamE (var : Symbol) (body : ParamExp)])
(define param-env (make-parameter mt-env))
(define (interp exp env)
(type-case ParamExp exp
[(varE name) (lookup name env)]
[(numE n) (numV n)]
[(let1E var bound-exp body)
(interp body (extend env var (interp bound-exp env)))]
[(appE f a)
(let ([fv (interp f env)]
[av (interp a env)])
(type-case ParamValue fv
[(funV v b f-env) (interp b (extend f-env v av))]
[else (error 'app "not a function")]))]
[(param1E var exp body) ....]
[(paramRefE var) ....]
[(lamE var body) (funV var body env)]))
)
(require 'param-mod)
(module+ test
(test (interp (let1E 'x (numE 1)
(let1E 'f (lamE 'y (varE 'x))
(let1E 'x (numE 2)
(appE (varE 'f) (numE 42))))) mt-env)
(numV 1))
(test (interp (param1E 'x (numE 1)
(let1E 'f (lamE 'y (paramRefE 'x))
(param1E 'x (numE 2)
(appE (varE 'f) (numE 42))))) mt-env)
(numV 2))
)
(module numlist plait
(define-type NumList
[Cons (n : Number) (lst : NumList)]
[Empty])
(define-syntax List
(syntax-rules ()
[(_ ...) ....]))
(define (nl-test0) (List))
(define (nl-test1) (List 1))
(define (nl-test3) (List 1 2 3))
)
(require 'numlist)
(module+ test
(test (nl-test0) (Empty))
(test (nl-test1) (Cons 1 (Empty)))
(test (nl-test3) (Cons 1 (Cons 2 (Cons 3 (Empty))))))
(module obj racket
(require [only-in plait ....])
(provide o-cons o-mt o-sum msg)
(define (msg obj selector . args) (apply (obj selector) args))
(define (o-mt)
(let ([self 'dummy])
(begin (set! self (lambda (m) .... )) self)))
(define (o-cons n lst)
(let ([self 'dummy])
(begin (set! self (lambda (m) .... )) self)))
(define (o-sum lst)
(cond
[(msg lst 'empty?) 0]
[else (+ (msg lst 'first)
(o-sum (msg lst 'rest)))]))
)
(require 'obj)
(module+ test
(test (msg (o-mt) 'empty?) #t)
(test (msg (o-cons 1 (o-mt)) 'empty?) #f)
(test (o-sum (o-mt)) 0)
(test (o-sum (o-cons 3 (o-cons 2 (o-cons 1 (o-mt))))) 6))
(module interp-k-mod plait
(define-type ContExp
[cnumE (n : Number)]
[cplusE (l : ContExp) (r : ContExp)]
[cerrE (s : String)])
(define-type ContValue
[cnumV (n : Number)]
[cerrV (s : String)])
(define (interp/k exp k)
(type-case ContExp exp
[(cnumE n) (k (cnumV n))]
[(cplusE l r)
(local
[(define (cont [l-v : ContValue]) : ContValue ....)]
(interp/k l cont))]
[(cerrE s) (cerrV s)]))
)
(require 'interp-k-mod)
(module+ test
(test
(interp/k (cplusE (cnumE 1) (cnumE 2)) identity)
(cnumV 3))
(test
(interp/k (cplusE (cnumE 1) (cerrE "abort!")) identity)
(cerrV "abort!"))
(test
(interp/k (cplusE (cerrE "abort!") (cnumE 2)) identity)
(cerrV "abort!"))
(test
(interp/k (cplusE (cnumE 1) (cplusE (cerrE "abort!") (cnumE 2))) identity)
(cerrV "abort!"))
(test
(interp/k (cplusE
(cplusE (cnumE 1)
(cplusE (cnumE 3) (cplusE (cerrE "abort!") (cnumE 2))))
(cnumE 42))
identity)
(cerrV "abort!"))
)
(module gc-mod racket
(provide current-heap find-free-space gc:alloc-flat gc:vec
init-allocator mark-white! read-root simple-root with-heap)
(require [only-in plait test test/exn print-only-errors ....])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This part provides a small part of the plai/gc2/collector language
(define current-heap (make-parameter (make-vector 0 #f)))
(define (heap-set! index val) (vector-set! (current-heap) index val))
(define (heap-ref index) (vector-ref (current-heap) index))
(define (heap-size) (vector-length (current-heap)))
(define-syntax-rule (with-heap vec expr ...)
(parameterize
([current-heap vec])
(begin
expr ...)))
(define (init-allocator)
(vector-fill! (current-heap) 'free))
(define (malloc size)
(define ptr (find-free-space size))
(unless ptr (error 'alloc "out of memory"))
ptr)
(define (simple-root loc) (box loc))
(define (read-root root) (unbox root))
(define (gc:alloc-flat val)
(let ([loc (malloc 2)])
(heap-set! loc 'flat)
(heap-set! (add1 loc) val)
loc))
(define (n-free-blocks? start n)
(for/fold ([ok #t])
([i (in-range start (+ start n))])
(and ok (< i (heap-size)) (equal? (heap-ref i) 'free))))
(define (find-free-space n)
(define (loop start)
(and
(< start (heap-size))
(case (heap-ref start)
[(flat) (loop (+ start 2))]
[(vec) ....]
[(free) (if (n-free-blocks? start n)
start
(loop (+ start 1)))]
[else (error 'find-free-space
"unexpected tag ~a" start)])))
(loop 0))
(define (gc:vec . vals) ....)
(define (mark-white!)
(define (loop loc)
(when (< loc (heap-size))
(case (heap-ref loc)
[(free) (loop (add1 loc))]
[(flat) (heap-set! loc 'white-flat) (loop (+ 2 loc))]
[(vec) ....]
[(white-flat) (loop (+ 2 loc))]
[(white-vec) ....])))
(loop 0))
)
(require 'gc-mod)
(module+ test
(test (with-heap (vector 'vec 3 1 2 3 'free 'free)
(find-free-space 2))
5)
(test
(with-heap (make-vector 6 #f)
(init-allocator)
(gc:vec (simple-root 4) (simple-root 5) (simple-root 6))
(current-heap))
#(vec 3 4 5 6 free))
(with-heap (make-vector 10 #f)
(init-allocator)
(define f1 (gc:alloc-flat 'flat))
(define f2 (gc:alloc-flat 'vec))
(gc:vec (simple-root f1) (simple-root f2))
(test (current-heap) #(flat flat flat vec vec 2 0 2 free free))
(gc:alloc-flat 'vec)
(test (current-heap) #(flat flat flat vec vec 2 0 2 flat vec))
(mark-white!)
(test (current-heap)
#(white-flat flat white-flat vec white-vec 2 0 2 white-flat vec)))
)