Adding PLAI software to the core

svn: r18101

collects/plai/CHANGELOG

@@ -0,0 +1,212 @@
+February 2010
+-------------
+Adding to core
+
+From Robby:
+- added test-random-mutator.ss
+- added docs at the end of plai.scrbl
+- added random-mutator.ss
+- changed gc-gui.ss
+
+March 2009
+----------
+
+Updated by JM to PLT 4.1.5 and PLaneT distribution
+
+
+PLAI-4.1.3 (6 December 2008)
+----------------------------
+
++ The GC languages are now compatible with PLT Scheme 4.1.3.
+
++ plai/mutator supports halt-on-errors and print-only-errors.
+
++ Defining a global as an alias for a primitive now works correctly.
+  Previously, a mutator containing a definition such as (define car first) would
+  signal a contract violation.
+
++ A mutator with just allocator-setup and no expression no longer signals a
+  syntax error.
+
++ When installed for --all-users, scribble docs should be in the plai
+  directory and not the manual directory.
+
++ Allocations made in init-allocator are now displayed in the heap 
+  visualization.
+
+
++ Error reporting for type-case and define-type has improved.
+
++ Importing was not broken in the previous release.  Documentation clarified
+  with an example.
+
++ Documentation for gc:set-first! and gc:set-rest! was missing; it's now
+  present.
+
+
+PLAI-4.1.1 (28 October 2008)
+----------------------------
+
++ plai/gc-test.ss and plai/plai-test.ss removed.  They are part of the
+  173tourney (test-fest) distribution.
+
++ Fixed a bug in the GC Mutator languages that manifested itself as missing
+  roots in (get-root-set).  For example, in the previous release, the following   program does not signal an error:
+
+  (allocator-setup "mark-and-sweep.ss" 3) ; assume that 5 occupies 3 locations
+
+  (5 (lambda (x) x))
+
+Known Issues:
+
++ A mutator with just an allocator-setup line and no other expressions signals
+  an error.
+
++ import-gc does not work in all contexts.
+
+
+PLAI-4.1 (August 2008)
+----------------------
+
++ plai/gc-test is analogous to plai/plai-test, but for the GC languages.
+
++ The 'alternate-collector' parameter in plai/private/command-line may be set
+  to override the collector specified in 'allocator-setup' in Mutator Scheme.
+  Note that this parameter is examined during macro expansion.  Set it using
+  'begin-for-syntax' before requiring the mutator.
+
++ The '--plai-gc-no-custom-imports' commmand line argument has been removed.
+  The 'gc-disable-import-gc?' parameter in plai/private/command-line may be used
+  to achieve the same effect for 'import-gc' but not 'import-primitive'.
+
++ The 'error' function in the PLAI language now has the same signature as
+  'error' in scheme/base.
+
++ In Mutator Scheme, define works in the interactions pane.
+
++ Mutator Scheme no longer provides letrec, named let and letrec-values.  These
+  expressions were broken in earlier versions of PLAI.
+
++ Mutator Scheme includes 'begin'.
+
++ In Mutator Scheme, primitive expression that expand to use quote are 
+  properly annotated.  (Bug introduced in PLAI-4.)
+
++ In Mutator Scheme, else-branches are available for cond and case. (Bug
+  introduced in PLAI-4.)
+
++ The 'Stop' button in plai/web works better.
+
++ test/exn, test and other testing macros produce more helpful errors when
+  reporting on exceptions.  When either fails because an exception is raised
+  that is not explicitly signalled by the user, they both print
+
+  (exception <evaluated-expression> <exception-message> <location>)
+
+  where <exception-message> is the message of the exception that was signalled.
+
+  For example,
+
+  (test (/ 1 0) "system exception")
+  > (exception (/ 1 0) "/: division by zero" "at line 1")
+
++ When test fails because *any* exception is raised, it prints (exception ...)
+  as above.
+
++ When test/exn fails because an exception with a mismatched error message is
+  signalled, it prints (bad ...) as in previous versions of PLAI.
+
++ plai/plai-test.ss is a script for running solutions against an external
+  test file.
+
++ plai/private/command-line defines various parameters that affect PLAI
+  (largely tests).  Some of these parameters aren't available without requiring
+  this module.
+
+PLAI-4 (July 2008)
+------------------
+
++ PLAI software has been updated for PLT Scheme 4.0.  
+
++ The PLAI Restricted / PLAI Pretty Big distinction has been removed.  There is
+  now a single PLAI Scheme language, which extends `#lang scheme' with
+  `define-type', `type-case' and the testing procedures.
+
++ PLAI languages are also available as module languages.  Use `#lang plai',
+  `#lang plai/collector' and `#lang plai/mutator'.
+
++ PLAI exceptions are subtypes of exn:fail instead of exn.
+
++ In the GC Mutator language, when expressions are evaluated in the REPL, the
+  value is printed in addition to the address of the value.
+
++ In the GC Mutator language, circular data structures print correctly in the
+  REPL.
+
++ The GC Mutator language includes support for testing.  See `test/value=?'
+  and `test/location=?'.
+
++ The testing framework no longer provides the print-tests parameter.  See
+  `halt-on-errors' and `print-only-errors' instead.  The arguments
+  `--plai-halt-on-errors' and `--plai-print-only-errors' may be specified
+  on the command line as well.
+
++ The testing framework no longer provides procedural (*/proc) testing forms.
+
++ The GC Mutator language dynamically loads MrEd when it's available.  Hence,
+  it may be executed on the command-line.
+
++ In the GC Mutator language, if the heap size specified exceeds 200 locations,
+  the heap visualization is not displayed.
+
++ The heap-offset notion has been removed from the GC languages.  Heaps now
+  begin at address 0 only.  `allocator-setup' has been affected and 
+  `heap-offset' has been removed.
+
++ Testing forms print the supplied expressions, instead of their values.  For
+  example, (test (+ 2 3) 5) prints (good (+ 2 3) 5) instead of (good 5 5).
+
++ GC Mutator allows arbitrary procedures to be imported from the collector
+  and from #lang scheme.  See `import-gc' and `import-primitives'.  These
+  forms may be disabled on the command line with the switch
+  `--plai-gc-no-custom-imports'.
+
++ A 'web application' language level has been added to ease experiments with
+  the PLT Web Server.
+
+PLAI-v371/372 (January 2008)
+----------------------------
+
++ Fixed `type-case' to report the correct error location when an element of a
+  field list is not an identifier.
+
+  (type-case WAE expr
+    [num (10) 5] 
+    ...)  => expected an identifier at 10
+
++ `define-type' gives a more helpful error messages if it isn't given any
+  arguments.
+
++ PLAI Pretty Big Scheme is now derived from plt-pretty-big-text.  This allows
+  you to run the language in MzScheme.
+
++ The testing framework defines the parameter `plai-ignore-exn-strings.' When
+  set to true, exception strings passed to test/exn, test/regexp, etc. are
+  treated as the empty string.  The default value of this parameter is false.
+
++ The testing framework defines the variable `plai-all-test-results.'  This
+  variable is a list of test results (i.e. (good ...), (bad ...), 
+  (exception ...)).
+
++ cons? and empty? signal an error if they are not provided with a `list?'
+
++ cons requires its second argument to be a list.
+
++ PLAI Restricted Scheme now provides `when' and `unless'.
+
++ Modules (i.e. files) written in PLAI Pretty Big and PLAI Restricted now
+  automatically (provide (all-defined)).
+
++ plai-ignore-exn-strings and plai-all-test-results; see doc.txt for details.
+
++ The collector-lang now provides all-from (lib "list.ss") and (lib "etc.ss").

collects/plai/collector.ss

@@ -0,0 +1,62 @@
+#lang scheme
+
+(require (for-syntax scheme)
+         plai/datatype
+         plai/test-harness
+         plai/private/gc-core)
+
+(provide (except-out (all-from-out scheme) #%module-begin error)
+         (all-from-out plai/private/gc-core)
+         (all-from-out plai/datatype)
+         (rename-out
+          [plai-error error])
+         (except-out (all-from-out plai/test-harness))
+         (rename-out 
+          [collector-module-begin #%module-begin]))
+
+(provide with-heap)
+(define-syntax-rule (with-heap heap exp ...) (with-heap/proc heap (λ () exp ...)))
+(define (with-heap/proc vec h)
+  (unless (vector? vec)
+    (error 'with-heap "expected a vector as first argument, got ~e" vec))
+  (for ([v (in-vector vec)]
+        [i (in-naturals)])
+    (unless (heap-value? v)
+      (error 'with-heap "expected the heap to contain only heap values, but found ~e at position ~a"
+             v i)))
+  (parameterize ([current-heap vec])
+    (h)))
+
+;;; Since we explicitly identify the procedures to be exported here, an error is raised in the
+;;; collector if a procedure is not defined.
+(define-syntax (collector-module-begin stx)
+  (syntax-case stx ()
+    [(_ body ...) 
+     (with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons gc:first gc:rest gc:flat?
+                                    gc:cons? gc:set-first! gc:set-rest!)
+                    (map (λ (s) (datum->syntax stx s))
+                         '(init-allocator gc:deref gc:alloc-flat gc:cons gc:first gc:rest gc:flat? 
+                                          gc:cons? gc:set-first! gc:set-rest!))])
+       #`(#%module-begin 
+          
+          (require (for-syntax scheme))
+          
+          (provide/contract (init-allocator (-> any)))
+          
+          (provide/contract (gc:deref (location? . -> . heap-value?)))
+          
+          (provide/contract (gc:alloc-flat (heap-value? . -> . location?)))
+          (provide/contract (gc:cons (location? location? . -> . location?)))
+          
+          (provide/contract (gc:first (location? . -> . location?)))
+          (provide/contract (gc:rest (location? . -> . location?)))
+          
+          (provide/contract (gc:flat? (location? . -> . boolean?)))
+          (provide/contract (gc:cons? (location? . -> . boolean?)))
+          
+          (provide/contract (gc:set-first! (location? location? . -> . void?)))
+          (provide/contract (gc:set-rest! (location? location? . -> . void?)))
+          
+          body ...
+          
+          ))]))

collects/plai/collector/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  #:language `plai/collector)

collects/plai/datatype.ss

@@ -0,0 +1,366 @@
+#lang scheme
+(require (for-syntax scheme/list))
+
+(provide define-type type-case)
+
+(define-for-syntax (plai-syntax-error id stx-loc format-string . args)
+  (raise-syntax-error 
+   id (apply format (cons format-string args)) stx-loc))
+
+(define bug:fallthru-no-else
+  (string-append 
+   "You have encountered a bug in the PLAI code.  (Error: type-case "
+   "fallthru on cond without an else clause.)"))
+(define-for-syntax bound-id
+  (string-append
+   "identifier is already bound in this scope (If you didn't define it, "
+   "it was defined by the PLAI language.)"))
+(define-for-syntax type-case:generic
+  (string-append
+   "syntax error in type-case; search the Help Desk for `type-case' for "
+   "assistance."))
+(define-for-syntax define-type:duplicate-variant
+  "this identifier has already been used")
+(define-for-syntax type-case:not-a-type
+  "this must be a type defined with define-type")
+(define-for-syntax type-case:not-a-variant
+  "this is not a variant of the specified type")
+(define-for-syntax type-case:argument-count
+  "this variant has ~a fields, but you provided bindings for ~a fields")
+(define-for-syntax type-case:missing-variant
+  "syntax error; probable cause: you did not include a case for the ~a variant, or no else-branch was present")
+(define-for-syntax type-case:unreachable-else
+  "the else branch of this type-case is unreachable; you have matched all variants")
+(define-for-syntax define-type:zero-variants
+  "you must specify a sequence of variants after the type, ~a")
+
+(define-for-syntax ((assert-unbound stx-symbol) id-stx)
+  (when (identifier-binding id-stx)
+    (plai-syntax-error stx-symbol id-stx bound-id)))
+
+(define-for-syntax (assert-unique variant-stx)
+  (let ([dup-id (check-duplicate-identifier (syntax->list variant-stx))])
+    (when dup-id
+      (plai-syntax-error 'define-type dup-id 
+                         define-type:duplicate-variant))))
+
+(define-for-syntax type-symbol (gensym))
+
+(define-for-syntax (validate-and-remove-type-symbol stx-loc lst)
+  (if (and (list? lst) (eq? type-symbol (first lst)))
+      (rest lst)
+      (plai-syntax-error 'type-case stx-loc type-case:not-a-type)))
+
+(require (for-syntax syntax/parse
+                     unstable/syntax
+                     (only-in scheme/function curry)))
+
+(define-for-syntax (syntax-string s)
+  (symbol->string (syntax-e s)))
+
+(define-syntax (define-type stx)
+  (define (format-id/std fmt x)
+    (format-id stx fmt #:source x x))
+  (syntax-parse
+   stx
+   [(_ datatype:id
+       [variant:id (field:id field/c:expr) ...]
+       ...)
+    
+    ; Ensure we have at least one variant.
+    (when (empty? (syntax->list #'(variant ...)))
+      (plai-syntax-error 'define-type stx define-type:zero-variants
+                         (syntax-e #'datatype)))
+    
+    ; Ensure variant names are unique.
+    (assert-unique #'(variant ...))
+    ; Ensure each set of fields have unique names.
+    (syntax-map assert-unique #'((field ...) ...))
+    
+    ; Ensure type and variant names are unbound
+    (map (assert-unbound 'define-type)
+         (cons #'datatype? (syntax->list #'(variant ...))))
+    (with-syntax
+        ([(variant* ...) 
+          (map (lambda (s)
+                 (datum->syntax stx (syntax->datum s)))
+               (generate-temporaries #'(variant ...)))])
+      
+      (with-syntax
+          ([((field/c-val ...) ...)
+            (syntax-map generate-temporaries #'((field/c ...) ...))]
+           [datatype?
+            (format-id/std "~a?" #'datatype)]
+           [(variant? ...)
+            (syntax-map (curry format-id/std "~a?") #'(variant ...))]
+           [(variant*? ...)
+            (syntax-map (curry format-id/std "~a?") #'(variant* ...))]
+           [(make-variant ...)
+            (syntax-map (curry format-id/std "make-~a") #'(variant ...))]
+           [(make-variant* ...)
+            (syntax-map (curry format-id/std "make-~a") #'(variant* ...))])
+        
+        (with-syntax
+            ([((f:variant? ...) ...)
+              (syntax-map (lambda (v? fs)
+                            (syntax-map (lambda (f) v?) fs))
+                          #'(variant? ...)
+                          #'((field ...) ...))]
+             [((variant-field ...) ...)
+              (syntax-map (lambda (variant fields)
+                            (syntax-map (curry format-id/std (string-append (syntax-string variant) "-~a"))
+                                        fields))
+                          #'(variant ...)
+                          #'((field ...) ...))]
+             [((variant*-field ...) ...)
+              (syntax-map (lambda (variant fields)
+                            (syntax-map (curry format-id/std (string-append (syntax-string variant) "-~a"))
+                                        fields))
+                          #'(variant* ...)
+                          #'((field ...) ...))]
+             
+             [((set-variant-field! ...) ...)
+              (syntax-map (lambda (variant fields)
+                            (syntax-map (curry format-id/std (string-append "set-" (syntax-string variant) "-~a!"))
+                                        fields))
+                          #'(variant ...)
+                          #'((field ...) ...))]
+             [((set-variant*-field! ...) ...)
+              (syntax-map (lambda (variant fields)
+                            (syntax-map (curry format-id/std (string-append "set-" (syntax-string variant) "-~a!"))
+                                        fields))
+                          #'(variant* ...)
+                          #'((field ...) ...))])
+          
+          (syntax/loc stx
+            (begin
+              (define-syntax datatype
+                (list type-symbol
+                      (list (list #'variant (list #'variant-field ...) #'variant?)
+                            ...)
+                      #'datatype?))
+              (define-struct variant* (field ...)
+                #:transparent
+                #:omit-define-syntaxes
+                #:mutable
+                #:property
+                prop:custom-write
+                (lambda (v port write?)
+                  ((if write? write display)
+                   (list 'variant
+                         (variant-field v)
+                         ...)
+                   port)))
+              ...
+              (define variant? 
+                (flat-named-contract 'variant? variant*?))
+              ...
+              (define (datatype? x)
+                (or (variant? x) ...))
+              (begin
+                ; If this is commented in, then contracts will be checked early.
+                ; However, this will disallow mutual recursion, which PLAI relies on.
+                ; It could be allowed if we could have module-begin cooperate and lift the define-struct to the top-level
+                ; but, that would break web which doesn't use the plai language AND would complicate going to a student-language based deployment
+                #;(define field/c-val field/c)
+                ;...
+                (define make-variant
+                  (lambda-memocontract (field ...)
+                                       (contract (field/c ... . -> . variant?)
+                                                 make-variant*
+                                                 'make-variant 'use)))
+                (define variant
+                  (lambda-memocontract (field ...)
+                                       (contract (field/c ... . -> . variant?)
+                                                 make-variant*
+                                                 'variant 'use)))
+                (define variant-field
+                  (lambda-memocontract (v)
+                                       (contract (f:variant? . -> . field/c)
+                                                 variant*-field
+                                                 'variant-field 'use)))
+                ...
+                (define set-variant-field!
+                  (lambda-memocontract (v)
+                                       (contract (f:variant? field/c . -> . void)
+                                                 set-variant*-field!
+                                                 'set-variant-field! 'use)))
+                ...
+                )
+              ...)))))]))
+
+(define-syntax-rule (lambda-memocontract (field ...) c-expr)
+  (let ([cd #f])
+    (lambda (field ...)
+      (unless cd
+        (set! cd c-expr))
+      (cd field ...))))
+
+;;; Asserts that variant-id-stx is a variant of the type described by 
+;;; type-stx.
+(define-for-syntax ((assert-variant type-info) variant-id-stx)
+  (unless (ormap (λ (stx) (free-identifier=? variant-id-stx stx)) 
+                 (map first type-info))
+    (plai-syntax-error 'type-case variant-id-stx type-case:not-a-variant)))
+
+;;; Asserts that the number of fields is appropriate.
+(define-for-syntax ((assert-field-count type-info) variant-id-stx field-stx)
+  (let ([field-count
+         (ormap (λ (type) ; assert-variant first and this ormap will not fail
+                  (and (free-identifier=? (first type) variant-id-stx)
+                       (length (second type))))
+                type-info)])
+    (unless (= field-count (length (syntax->list field-stx)))
+      (plai-syntax-error 'type-case variant-id-stx type-case:argument-count 
+                         field-count (length (syntax->list field-stx))))))
+
+(define-for-syntax ((ensure-variant-present stx-loc variants) variant)
+  (unless (ormap (λ (id-stx) (free-identifier=? variant id-stx))
+                 (syntax->list variants))
+    (plai-syntax-error 'type-case stx-loc type-case:missing-variant 
+                       (syntax->datum variant))))
+
+(define-for-syntax ((variant-missing? stx-loc variants) variant)
+  (not (ormap (λ (id-stx) (free-identifier=? variant id-stx))
+              (syntax->list variants))))
+
+
+(define-syntax (lookup-variant stx)
+  (syntax-case stx ()
+    [(_ variant-id ((id (field ...) id?) . rest))
+     (free-identifier=? #'variant-id #'id)
+     #'(list (list field ...) id?)]
+    [(_ variant-id (__ . rest)) #'(lookup-variant variant-id rest)]
+    [(_ variant-id ()) (error 'lookup-variant "variant ~a not found (bug in PLAI code)"
+                              (syntax-e #'variant-id))]))
+
+(define-for-syntax (validate-clause clause-stx)
+  (syntax-case clause-stx ()
+    [(variant (field ...) body ...)
+     (cond
+       [(not (identifier? #'variant))
+        (plai-syntax-error 'type-case #'variant
+                           "this must be the name of a variant")]
+       [(ormap (λ (stx) 
+                 (and (not (identifier? stx)) stx)) (syntax->list #'(field ...)))
+        => (λ (malformed-field)
+             (plai-syntax-error
+              'type-case malformed-field
+              "this must be an identifier that names the value of a field"))]
+       [(not (= (length (syntax->list #'(body ...))) 1))
+        (plai-syntax-error 
+         'type-case clause-stx
+         (string-append
+          "there must be just one body expression in a clause, but you "
+          "provided ~a body expressions.")
+         (length (syntax->list #'(body ...))))]
+       [else #t])]
+    [(variant (field ...))
+     (plai-syntax-error
+      'type-case clause-stx
+      "this case is missing a body expression")]
+    [_ 
+     (plai-syntax-error
+      'type-case clause-stx
+      "this case is missing a field list (possibly an empty field list)")]))
+
+(define-syntax (bind-fields-in stx)
+  (syntax-case stx ()
+    [(_ (binding-name ...) case-variant-id ((variant-id (selector-id ...) ___) . rest) value-id body-expr)
+     (if (free-identifier=? #'case-variant-id #'variant-id)
+         #'(let ([binding-name (selector-id value-id)]
+                 ...)
+             body-expr)
+         #'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))]))
+
+(define-syntax (type-case stx)
+  (syntax-case stx (else)
+    [(_ type-id test-expr [variant (field ...) case-expr] ... [else else-expr])
+     ; Ensure that everything that should be an identifier is an identifier.
+     (and (identifier? #'type-id)
+          (andmap identifier? (syntax->list #'(variant ...)))
+          (andmap (λ (stx) (andmap identifier? (syntax->list stx)))
+                  (syntax->list #'((field ...) ...))))
+     (let* ([info (validate-and-remove-type-symbol
+                   #'type-id (syntax-local-value #'type-id (λ () #f)))]
+            [type-info (first info)]
+            [type? (second info)])
+       
+       ; Ensure all names are unique
+       (assert-unique #'(variant ...))
+       (map assert-unique (syntax->list #'((field ...) ...)))
+       
+       ; Ensure variants are valid.
+       (map (assert-variant type-info) (syntax->list #'(variant ...)))
+       
+       ; Ensure field counts match.
+       (map (assert-field-count type-info) 
+            (syntax->list #'(variant ...))
+            (syntax->list #'((field ...) ...)))
+       
+       ; Ensure some variant is missing.
+       (unless (ormap (variant-missing? stx #'(variant ...)) 
+                      (map first type-info))
+         (plai-syntax-error 'type-case stx type-case:unreachable-else))
+       
+       
+       #`(let ([expr test-expr])
+           (if (not (#,type? expr))
+               #,(syntax/loc #'test-expr 
+                   (error 'type-case "expected a value from type ~a, got: ~a"
+                          'type-id
+                          expr))
+               (cond
+                 [(let ([variant-info (lookup-variant variant #,type-info)])
+                    ((second variant-info) expr))
+                  (bind-fields-in (field ...) variant #,type-info expr case-expr)]
+                 ...
+                 [else else-expr]))))]
+    [(_ type-id test-expr [variant (field ...) case-expr] ...)
+     ; Ensure that everything that should be an identifier is an identifier.
+     (and (identifier? #'type-id)
+          (andmap identifier? (syntax->list #'(variant ...)))
+          (andmap (λ (stx) (andmap identifier? (syntax->list stx)))
+                  (syntax->list #'((field ...) ...))))
+     (let* ([info (validate-and-remove-type-symbol 
+                   #'type-id (syntax-local-value #'type-id (λ () #f)))]
+            [type-info (first info)]
+            [type? (second info)])
+       
+       ; Ensure all names are unique
+       (assert-unique #'(variant ...))
+       (map assert-unique (syntax->list #'((field ...) ...)))
+       
+       ; Ensure variants are valid.
+       (map (assert-variant type-info) (syntax->list #'(variant ...)))
+       
+       ; Ensure field counts match.
+       (map (assert-field-count type-info) 
+            (syntax->list #'(variant ...))
+            (syntax->list #'((field ...) ...)))
+       
+       ; Ensure all variants are covered
+       (map (ensure-variant-present stx #'(variant ...))
+            (map first type-info))
+       
+       #`(let ([expr test-expr])
+           (if (not (#,type? expr))
+               #,(syntax/loc #'test-expr 
+                   (error 'type-case "expected a value from type ~a, got: ~a"
+                          'type-id
+                          expr))
+               (cond
+                 [(let ([variant-info (lookup-variant variant #,type-info)])
+                    ((second variant-info) expr))
+                  (bind-fields-in (field ...) variant #,type-info expr case-expr)]
+                 ...
+                 [else (error 'type-case bug:fallthru-no-else)]))))]
+    ;;; The remaining clauses are for error reporting only.  If we got this
+    ;;; far, either the clauses are malformed or the error is completely
+    ;;; unintelligible.
+    [(_ type-id test-expr clauses ...)
+     (map validate-clause (syntax->list #'(clauses ...)))]
+    [_ (plai-syntax-error 'type-case stx type-case:generic)]))
+
+
+

collects/plai/info.ss

@@ -0,0 +1,22 @@
+#lang setup/infotab
+(require string-constants)
+
+(define name "PLAI")
+(define blurb '("Language levels for the Programming Languages: Application and Interpretation textbook"))
+(define homepage "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/")
+(define primary-file "main.ss")
+  
+(define scribblings '(("scribblings/plai.scrbl" () (language -11))))
+
+(define textbook-pls
+  (list (list '("plai-small.gif" "plai")
+              "Programming Languages: Application and Interpretation"
+              (string-constant teaching-languages)
+              "Programming Languages: Application and Interpretation")))
+
+(define tools (list "plai-tool.ss"))
+(define tool-icons (list "plai-small.gif"))
+(define tool-names 
+  (list "Programming Languages: Application and Interpretation"))
+(define tool-urls 
+  (list "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/"))

collects/plai/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  #:language `plai)

collects/plai/main.ss

@@ -0,0 +1,20 @@
+#lang scheme
+(require plai/datatype
+         plai/test-harness)
+
+(provide (all-from-out plai/datatype)
+         (except-out (all-from-out scheme) error (for-syntax error) #%module-begin provide)
+         (except-out (all-from-out plai/test-harness) plai-error)
+         (rename-out [plai-error error] 
+                     [plai-module-begin #%module-begin])
+         (rename-out [plai-provide provide]))
+
+(define-syntax (plai-provide stx)
+  (raise-syntax-error #f "The PLAI language provides all defined names" stx))
+
+(define-syntax (plai-module-begin stx)
+  (syntax-case stx ()
+    [(_ body ...)
+     #`(#%module-begin
+        (provide #,(datum->syntax stx '(all-defined-out)))
+        body ...)]))

collects/plai/mutator.ss

@@ -0,0 +1,511 @@
+#lang scheme
+(require (prefix-in scheme: scheme)
+         plai/private/command-line
+         (for-syntax plai/private/command-line)
+         plai/private/collector-exports
+         plai/private/gc-core
+         scheme/gui/dynamic
+         (only-in plai/test-harness
+                  generic-test test halt-on-errors print-only-errors)
+         (for-syntax scheme)
+         (for-syntax plai/private/gc-transformer)
+         scheme/stxparam
+         (for-syntax scheme/stxparam-exptime))
+
+(provide else require provide
+         test/location=? 
+         test/value=?
+         (rename-out
+          [mutator-and and]
+          [mutator-or or]
+          [mutator-cond cond]
+          [mutator-case case]
+          [mutator-define define]
+          [mutator-define-values define-values]
+          (mutator-let let)
+          [mutator-let* let*]
+          [mutator-begin begin]
+          
+          [mutator-if if]
+          [mutator-let-values let-values]
+          [mutator-set! set!]
+          [mutator-lambda lambda]
+          [mutator-lambda λ]
+          (mutator-app #%app)
+          (mutator-datum #%datum)
+          (collector:cons cons)
+          (collector:first first)
+          (collector:rest rest)
+          (mutator-quote quote)
+          (mutator-top-interaction #%top-interaction)
+          (mutator-module-begin #%module-begin)))
+
+(define-syntax-parameter mutator-tail-call? #t)
+(define-syntax-parameter mutator-env-roots empty)
+
+; Sugar Macros
+(define-syntax-rule (->address e) e)
+(define-syntax mutator-and
+  (syntax-rules ()
+    [(_) (mutator-quote #t)]
+    [(_ fe) fe]
+    [(_ fe e ...) (mutator-if fe (mutator-and e ...) (mutator-quote #f))]))
+(define-syntax mutator-or
+  (syntax-rules ()
+    [(_) (mutator-quote #f)]
+    [(_ fe) fe]
+    [(_ fe e ...) (mutator-let ([tmp fe]) (mutator-if tmp tmp (mutator-or e ...)))]))
+(define-syntax mutator-cond
+  (syntax-rules (else)
+    [(_) (mutator-begin)]
+    [(_ [else e ...]) (mutator-begin e ...)]
+    [(_ [q ans] e ...) (mutator-if q ans (cond e ...))]))
+(define-syntax mutator-case
+  (syntax-rules (else)
+    [(_ value
+        [(v ...) e ...]
+        ...
+        [else ee ...])
+     (mutator-let ([tmp value])
+                  (mutator-cond [(mutator-app mutator-member? tmp (mutator-quote (v ...)))
+                                 e ...]
+                                ...
+                                [else ee ...]))]
+    [(_ value
+        [(v ...) e ...]
+        ...)
+     (mutator-case value
+                   [(v ...) e ...]
+                   ...
+                   [else (mutator-begin)])]))
+(define-syntax mutator-define
+  (syntax-rules ()
+    [(_ (f a ...) e ...)
+     (mutator-define-values (f) (mutator-lambda (a ...) e ...))]
+    [(_ id e)
+     (mutator-define-values (id) e)]))
+(define-syntax-rule (mutator-let ([id e] ...) be ...)
+  (mutator-let-values ([(id) e] ...) be ...))
+(define-syntax mutator-let*
+  (syntax-rules ()
+    [(_ () be ...)
+     (mutator-begin be ...)]
+    [(_ ([fid fe] [rid re] ...) be ...)
+     (mutator-let ([fid fe])
+                  (mutator-let* ([rid re] ...)
+                                be ...))]))
+(define-syntax mutator-begin
+  (syntax-rules ()
+    [(_) (mutator-app void)]
+    [(_ e) e]
+    [(_ fe e ...)
+     (mutator-let ([tmp fe]) (mutator-begin e ...))]))
+
+; Real Macros
+(define-syntax-rule (mutator-define-values (id ...) e)
+  (begin (define-values (id ...) 
+           (syntax-parameterize ([mutator-tail-call? #f])
+                                (->address e)))
+         (add-global-root! (make-env-root id))
+         ...))
+(define-syntax-rule (mutator-if test true false)
+  (if (syntax-parameterize ([mutator-tail-call? #f])
+                           (collector:deref (->address test)))
+      (->address true)
+      (->address false)))
+(define-syntax-rule (mutator-set! id e)
+  (begin
+    (set! id (->address e))
+    (mutator-app void)))
+(define-syntax (mutator-let-values stx)
+  (syntax-case stx ()
+    [(_ ([(id ...) expr]
+         ...)
+        body-expr)
+     (with-syntax ([((tmp ...) ...)
+                    (map generate-temporaries (syntax->list #'((id ...) ...)))])
+       (let ([binding-list (syntax->list #'((tmp ...) ...))])
+         (with-syntax ([((previous-tmp ...) ...)
+                        (build-list (length binding-list) 
+                                    (λ (n) (append-map syntax->list (take binding-list n))))])
+           (syntax/loc stx
+             (let*-values ([(tmp ...) 
+                            (syntax-parameterize ([mutator-env-roots 
+                                                   (list* #'previous-tmp ...
+                                                          (syntax-parameter-value #'mutator-env-roots))]
+                                                  [mutator-tail-call? #f])
+                                                 named-expr)]
+                           ...)
+               (let-values ([(id ...) (values tmp ...)]
+                            ...)
+                 (syntax-parameterize ([mutator-env-roots 
+                                        (list* #'id ... ...
+                                               (syntax-parameter-value #'mutator-env-roots))])
+                                      (->address body-expr))))))))]
+    [(_ ([(id ...) expr]
+         ...)
+        body-expr ...)
+     (syntax/loc stx
+       (mutator-let-values
+        ([(id ...) expr]
+         ...)
+        (mutator-begin body-expr ...)))]))
+(define-syntax (mutator-lambda stx)
+  (syntax-case stx ()
+    [(_ (id ...) body)
+     (let ([env-roots (syntax-parameter-value #'mutator-env-roots)])
+       (with-syntax ([(free-id ...) (find-referenced-locals env-roots stx)]
+                     [(env-id ...) env-roots]
+                     [closure (or (syntax-local-name)
+                                  (let ([prop (syntax-property stx 'inferred-name)])
+                                    (if (or (identifier? prop)
+                                            (symbol? prop))
+                                        prop
+                                        #f))
+                                  (string->symbol "#<proc>"))])
+         (quasisyntax/loc stx
+           (let ([closure (lambda (id ...) 
+                            (syntax-parameterize ([mutator-env-roots 
+                                                   (list* #'id ...
+                                                          (syntax-parameter-value #'mutator-env-roots))]
+                                                  [mutator-tail-call? #t])
+                                                 (->address body)))])
+             (add-closure-env! closure (list (make-env-root free-id) ...))
+             #,(if (syntax-parameter-value #'mutator-tail-call?)
+                   (syntax/loc stx
+                     (#%app collector:alloc-flat closure))
+                   (syntax/loc stx
+                     (with-continuation-mark gc-roots-key 
+                       (list (make-env-root env-id) ...)
+                       (#%app collector:alloc-flat closure))))))))]
+    [(_ (id ...) body ...)
+     (syntax/loc stx
+       (mutator-lambda (id ...) (mutator-begin body ...)))]))
+(define-syntax (mutator-app stx)
+  (syntax-case stx ()
+    [(_ e ...)
+     (local [(define (do-not-expand? exp)
+               (and (identifier? exp)
+                    (free-identifier=? exp #'empty)))
+             (define exps
+               (syntax->list #'(e ...)))
+             (define tmps
+               (generate-temporaries #'(e ...)))]
+       (with-syntax ([(ne ...)
+                      (map (lambda (exp tmp) (if (do-not-expand? exp) exp tmp))
+                           exps tmps)])
+         (for/fold ([acc (syntax/loc stx (mutator-anf-app ne ...))])
+           ([exp (in-list (reverse exps))]
+            [tmp (in-list (reverse tmps))])
+           (if (do-not-expand? exp)
+               acc
+               (quasisyntax/loc stx
+                 (mutator-let ([#,tmp #,exp])
+                              #,acc))))))]))
+(define-syntax (mutator-anf-app stx)
+  (syntax-case stx ()
+    [(_ fe ae ...)
+     (with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)])
+       (if (syntax-parameter-value #'mutator-tail-call?)
+           ; If this call is in tail position, we will not need access to its environment when it returns.
+           (syntax/loc stx ((deref fe) ae ...))
+           ; If this call is not in tail position, we make the environment at the call site
+           ; reachable.
+           #`(with-continuation-mark gc-roots-key 
+               (list (make-env-root env-id) ...)
+               #,(syntax/loc stx ((deref fe) ae ...)))))]))
+(define-syntax mutator-quote
+  (syntax-rules ()
+    [(_ (a . d))
+     (mutator-anf-app collector:cons (mutator-quote a) (mutator-quote d))]
+    [(_ s) 
+     (mutator-anf-app collector:alloc-flat 's)]))
+(define-syntax (mutator-datum stx)
+  (syntax-case stx ()
+    [(_ . e) 
+     (quasisyntax/loc stx (mutator-anf-app collector:alloc-flat (#%datum . e)))]))
+
+(define-syntax (mutator-top-interaction stx)
+  (syntax-case stx (require provide mutator-define mutator-define-values test/value=? import-primitives)
+    [(_ . (require . e))
+     (syntax/loc stx
+       (require . e))]
+    [(_ . (provide . e))
+     (syntax/loc stx
+       (provide . e))]
+    [(_ . (mutator-define . e))
+     (syntax/loc stx
+       (mutator-define . e))]
+    [(_ . (mutator-define-values . e))
+     (syntax/loc stx
+       (mutator-define-values . e))]
+    [(_ . (test/value=? . e))
+     (syntax/loc stx
+       (test/value=? . e))]
+    [(_ . (import-primitives . e))
+     (syntax/loc stx
+       (import-primitives . e))]
+    [(_ . expr)
+     (syntax/loc stx
+       (call-with-values
+        (lambda ()
+          (syntax-parameterize ([mutator-tail-call? #f])
+                               (->address expr)))
+        (case-lambda
+          [() (void)]
+          [(result-addr)
+           (cond
+             [(procedure? result-addr)
+              (printf "Imported procedure~n")
+              result-addr]
+             [(location? result-addr)
+              (printf "Value at location ~a:~n" result-addr)
+              (gc->scheme result-addr)])])))]))
+
+; Module Begin
+(define-for-syntax required-allocator-stx false)
+
+(define-for-syntax (allocator-setup-internal stx)
+  (with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons 
+                                 gc:first gc:rest 
+                                 gc:flat? gc:cons?
+                                 gc:set-first! gc:set-rest!)
+                 (map (λ (s) (datum->syntax stx s))
+                      '(init-allocator gc:deref gc:alloc-flat gc:cons 
+                                       gc:first gc:rest 
+                                       gc:flat? gc:cons?
+                                       gc:set-first! gc:set-rest!))])
+    (syntax-case stx ()
+      [(collector-module heap-size)
+       (begin
+         (set! required-allocator-stx 
+               (if (alternate-collector)
+                   (datum->syntax stx (alternate-collector))
+                   #'collector-module))
+         #`(begin
+             #,(if (alternate-collector)
+                   #`(require #,(datum->syntax #'collector-module (alternate-collector)))
+                   #`(require collector-module))
+             
+             (set-collector:deref! gc:deref)
+             (set-collector:alloc-flat! gc:alloc-flat)
+             (set-collector:cons! gc:cons)
+             (set-collector:first! gc:first)
+             (set-collector:rest! gc:rest)
+             (set-collector:flat?! gc:flat?)
+             (set-collector:cons?! gc:cons?)
+             (set-collector:set-first!! gc:set-first!)
+             (set-collector:set-rest!! gc:set-rest!)
+             
+             (init-heap! (#%datum . heap-size))
+             (when (gui-available?) 
+               (if (<= (#%datum . heap-size) 500)
+                   (set-ui! (dynamic-require `plai/private/gc-gui 'heap-viz%))
+                   (printf "Large heap; the heap visualizer will not be displayed.~n")))
+             (init-allocator)))]
+      [_ (raise-syntax-error 'mutator 
+                             "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)"
+                             stx)])))
+
+(define-for-syntax allocator-setup-error-msg
+  "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)")
+
+(define-syntax (mutator-module-begin stx)
+  (syntax-case stx (allocator-setup)
+    [(_ (allocator-setup . setup) module-expr ...)
+     (begin
+       (syntax-case #'setup ()
+         [(collector heap-size)
+          (begin
+            (unless (string? (syntax->datum #'collector))
+              (raise-syntax-error 'allocator-setup "expected a literal string" #'collector))
+            (unless (number? (syntax->datum #'heap-size))
+              (raise-syntax-error 'allocator-setup "expected a literal number" #'heap-size)))]
+         [_
+          (raise-syntax-error 'mutator allocator-setup-error-msg (syntax/loc #'setup (allocator-setup . setup)))])
+       #`(#%module-begin
+          #,(allocator-setup-internal #'setup)
+          (mutator-top-interaction . module-expr)
+          ...))]
+    [(_ first-expr module-expr ...)
+     (raise-syntax-error 'mutator allocator-setup-error-msg #'first-expr)]
+    [(_)
+     (raise-syntax-error 'mutator allocator-setup-error-msg)]))
+
+; User Macros
+(provide import-primitives)
+(define-syntax (import-primitives stx)
+  (syntax-case stx ()
+    [(_ id ...) 
+     (andmap identifier? (syntax->list #'(id ...)))
+     (with-syntax ([(renamed-id ...) (generate-temporaries #'(id ...))]
+                   [source (syntax-local-get-shadower
+                            (syntax-local-introduce #'scheme))])
+       #`(begin
+           (require (only-in source [id renamed-id] ...))
+           (define id
+             (lambda args
+               (unless (andmap (lambda (v) (and (location? v) (collector:flat? v))) args)
+                 (error 'id (string-append "all arguments must be <heap-value?>s, "
+                                           "even if the imported procedure accepts structured "
+                                           "data")))
+               (let ([result (apply renamed-id (map collector:deref args))])
+                 (cond
+                   [(void? result) (void)]
+                   [(heap-value? result) (collector:alloc-flat result)]
+                   [else 
+                    (error 'id (string-append "imported primitive must return <heap-value?>, "
+                                              "received ~a" result))]))))
+           ...))]
+    [(_ maybe-id ...) 
+     (ormap (λ (v) (and (not (identifier? v)) v)) (syntax->list #'(maybe-id ...)))
+     (let ([offending-stx (findf (λ (v) (not (identifier? v))) (syntax->list #'(maybe-id ...)))])
+       (raise-syntax-error 
+        #f "expected identifier to import" offending-stx))]
+    [(_ . __)
+     (raise-syntax-error #f "expected list of identifiers to import" stx)]
+    [_ (raise-syntax-error #f "expected open parenthesis before import-primitive")]))
+
+; User Functions
+(define (mutator-lift f) 
+  (lambda args
+    (let ([result (apply f (map collector:deref args))])
+      (if (void? result)
+          (void)
+          (collector:alloc-flat result)))))
+(define-syntax (provide/lift stx)
+  (syntax-case stx ()
+    [(_ id ...)
+     (andmap identifier? (syntax->list #'(id ...)))
+     (with-syntax ([(lifted-id ...) (generate-temporaries #'(id ...))])
+       #'(begin
+           (define lifted-id (mutator-lift id)) ...
+           (provide (rename-out [lifted-id id] ...))))]))
+
+(provide/lift 
+ symbol? boolean? number? symbol=?
+ add1 sub1 zero? + - * / even? odd? = < > <= >=)
+
+(define (member? v l)
+  (and (member v l) #t))
+(define (mutator-member? v l)
+  (collector:alloc-flat
+   (member? (collector:deref v)
+            (gc->scheme l))))
+
+(provide (rename-out (mutator-set-first! set-first!)))
+(define (mutator-set-first! x y)
+  (collector:set-first! x y)
+  (void))
+
+(provide (rename-out (mutator-set-rest! set-rest!)))
+(define (mutator-set-rest! x y)
+  (collector:set-rest! x y)
+  (void))
+
+(provide (rename-out [mutator-empty empty]))
+(define-syntax mutator-empty
+  (syntax-id-rules (mutator-empty)
+    [_ (mutator-quote ())]))
+
+(provide (rename-out (mutator-empty? empty?)))
+(define (mutator-empty? loc)
+  (cond
+    [(collector:flat? loc) 
+     (collector:alloc-flat (empty? (collector:deref loc)))]
+    [else 
+     (collector:alloc-flat false)]))
+
+(provide (rename-out [mutator-cons? cons?]))
+(define (mutator-cons? loc)
+  (collector:alloc-flat (collector:cons? loc)))
+
+(provide (rename-out [mutator-eq? eq?]))
+(define (mutator-eq? l1 l2)
+  (collector:alloc-flat (= l1 l2)))
+
+(provide (rename-out [mutator-printf printf]))
+(define-syntax (mutator-printf stx)
+  (syntax-case stx ()
+    [(_ fmt arg ...)
+     ; We must invoke mutator-app to A-normalize the arguments.
+     (syntax/loc stx 
+       (begin
+         (mutator-app printf (#%datum . fmt)
+                      (mutator-app gc->scheme arg) ...)
+         (void)))]))
+
+(provide (rename-out
+          (mutator-halt-on-errors halt-on-errors)
+          (mutator-print-only-errors print-only-errors)))
+(define-syntax (mutator-halt-on-errors stx)
+  (syntax-case stx ()
+    [(_) #'(halt-on-errors)]
+    [(_ arg) #'(#%app halt-on-errors (#%datum . arg))]))
+
+(define-syntax (mutator-print-only-errors stx)
+  (syntax-case stx ()
+    [(_) #'(print-only-errors)]
+    [(_ arg) #'(#%app print-only-errors (#%datum . arg))]))
+
+; Implementation Functions
+(define (deref proc/loc)
+  (cond
+    [(procedure? proc/loc) proc/loc]
+    [(location? proc/loc) (collector:deref proc/loc)]
+    [else (error 'deref "expected <location?> or <procedure?; received ~a" proc/loc)]))
+
+(define (gc->scheme loc)
+  (define-struct an-unset ())
+  (define unset (make-an-unset))
+  (define phs (make-hash))
+  (define (unwrap loc)
+    (if (hash-has-key? phs loc)
+        (hash-ref phs loc)
+        (begin
+          (local [(define ph (make-placeholder unset))]
+            (hash-set! phs loc ph)
+            (cond
+              [(collector:flat? loc)
+               (placeholder-set! ph (collector:deref loc))]
+              [(collector:cons? loc)
+               (local [(define car-ph (make-placeholder unset))
+                       (define cdr-ph (make-placeholder unset))]
+                 (placeholder-set! ph (cons car-ph cdr-ph))
+                 (placeholder-set! car-ph (unwrap (collector:first loc)))
+                 (placeholder-set! cdr-ph (unwrap (collector:rest loc))))]
+              [else 
+               (error (format "gc:flat? and gc:cons? both returned false for ~a" loc))])
+            (placeholder-get ph)))))
+  (make-reader-graph (unwrap loc)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Testing support
+
+(define-syntax (test/location=? stx)
+  (syntax-case stx ()
+    [(_ e1 e2)
+     (quasisyntax/loc stx
+       (mutator-let ([e1-addr e1]
+                     [e2-addr e2])
+                    (test e1 e2)))]))
+
+(define-for-syntax (flat-heap-value? v)
+  (or (number? v) (boolean? v)))
+
+(define-syntax (expand-scheme stx)
+  (syntax-case stx (mutator-quote mutator-datum)
+    [(_ val) (flat-heap-value? (syntax->datum #'val)) #'(#%datum . val)]
+    [(_ (mutator-datum . val))
+     #'(#%datum . val)]
+    [(_ (mutator-quote e))
+     #'(quote e)]
+    [_ 
+     (raise-syntax-error 'test/value=? "must be a number, boolean or a quoted value" stx)]))
+
+(define-syntax (test/value=? stx)
+  (syntax-case stx (mutator-quote)
+    [(_ mutator-expr scheme-datum)
+     (quasisyntax/loc stx
+       (mutator-let ([v1 mutator-expr])
+                    (test (gc->scheme v1) (expand-scheme scheme-datum))))]))

collects/plai/mutator/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  #:language `plai/mutator)

collects/plai/plai-tool.ss

@@ -0,0 +1,129 @@
+; Plenty of code borrowed from the HtDP languages.
+#lang scheme
+(require drscheme/tool
+         framework/preferences
+         plai/private/tool-private
+         string-constants)
+
+(provide tool@)
+
+(define tool@
+  (unit 
+    (import drscheme:tool^)
+    (export drscheme:tool-exports^)
+    
+    (define (language-extension %)
+      (class %
+        (inherit get-reader get-module)
+        (inherit-field reader-module module)
+        
+        (define/override (get-reader-module) reader-module)
+        
+        (define/override (front-end/complete-program port settings)
+          (plai-complete-program port settings (get-reader) (get-module)))
+        
+        ; drscheme/private/auto-language.ss insists on #reader
+        ; "#lang plai\n"
+        (define/override (get-metadata modname settings)
+          (string-append
+           ";; The first three lines of this file were inserted by DrScheme. They record metadata\n"
+           ";; about the language level of this file in a form that our tools can easily process.\n"
+           (format "#reader~s~n" reader-module)))
+        
+        ;; Change print style in default settings from 'write to 'constructor:
+        (define/override (default-settings)
+          (let ([s (super default-settings)])
+            (drscheme:language:make-simple-settings
+             (drscheme:language:simple-settings-case-sensitive s)
+             'constructor
+             (drscheme:language:simple-settings-fraction-style s)
+             (drscheme:language:simple-settings-show-sharing s)
+             (drscheme:language:simple-settings-insert-newlines s)
+             'test-coverage)))
+        
+        (define/override (metadata->settings metadata)
+          (default-settings))
+        
+        (define/override (get-metadata-lines) 3)
+        
+        (super-new)))
+    
+    
+    ;; module-based-language-extension :    (implements drscheme:language:module-based-language<%>) 
+    ;;                                   -> (implements drscheme:language:module-based-language<%>)
+    ;; changes the default settings and sets a few more paramters during `on-execute'
+    (define (module-based-language-extension super%)
+      (class* super% ()
+        
+        (init-field reader-module)
+        (define/override (default-settings)
+          (super default-settings))
+        
+        (define/override (marshall-settings x)
+          (super marshall-settings x))
+        
+        (define/override (unmarshall-settings x)
+          (super unmarshall-settings x))
+        
+        (super-new)))
+    
+    ; Returns #t if PLAI is being run for the first time and #f otherwise.
+    ; This is determined by the value of the plai:first-run field.  If the
+    ; field is not present, assume #t.
+    (define (is-first-run?)
+      (preferences:set-default 'plai:first-run #t boolean?)
+      (preferences:get 'plai:first-run))    
+    
+    ; Add type-case to lambda-like keywords, only if (is-first-run?) => #t.  PLT Scheme 4.0 adds ^def as a
+    ; regexp for define-like keywords.  Hence, we no longer have a clause here for define-type.
+    (define (setup-indentation!)
+      (when (is-first-run?)
+        (preferences:set 'plai:first-run #f)
+        (let ([indentation-ht (first (preferences:get 'framework:tabify))])
+          (hash-set! indentation-ht 'type-case 'lambda)
+          #;(hash-set! indentation-ht 'define-type 'define))))
+    
+    (define (phase1) (void))
+    
+    ;; phase2 : -> void
+    (define (phase2)
+      (local ([define plai-language%
+                ((drscheme:language:get-default-mixin)
+                 (language-extension
+                  (drscheme:language:module-based-language->language-mixin
+                   (module-based-language-extension
+                    (drscheme:language:simple-module-based-language->module-based-language-mixin
+                     drscheme:language:simple-module-based-language%)))))]
+              
+              [define next-language-number (box 1)]
+              
+              [define (add-plai-language #:summary summary #:module module #:title title #:reader reader-module)
+                (drscheme:language-configuration:add-language
+                 (instantiate plai-language% ()
+                   (one-line-summary summary)
+                   (module module)
+                   (reader-module reader-module) 
+                   (language-position (list (string-constant teaching-languages)
+                                            "Programming Languages: Application and Interpretation"
+                                            title))
+                   (language-numbers `(-500 -400 ,(unbox next-language-number)))))
+                (set-box! next-language-number (add1 (unbox next-language-number)))])
+        
+        (add-plai-language #:summary "Scheme with datatypes" 
+                           #:module `plai
+                           #:reader `plai/lang/reader
+                           #:title "PLAI Scheme")
+        (add-plai-language #:summary "language for writing garbage collectors"
+                           #:module `plai/collector
+                           #:reader `plai/collector/lang/reader
+                           #:title "GC Collector Scheme")
+        (add-plai-language #:summary "language for testing garbage collectors"
+                           #:module `plai/mutator
+                           #:reader `plai/mutator/lang/reader
+                           #:title "GC Mutator Scheme")
+        (add-plai-language #:summary "language for writing web applications"
+                           #:module `plai/web
+                           #:reader `plai/web/lang/reader
+                           #:title "Web Application")
+        (setup-indentation!)))
+    ))

collects/plai/private/collector-exports.ss

@@ -0,0 +1,39 @@
+#lang scheme
+(provide (all-defined-out))
+
+(define collector:deref false)
+(define collector:alloc-flat false)
+(define collector:cons false)
+(define collector:first false)
+(define collector:rest false)
+(define collector:flat? false)
+(define collector:cons? false)
+(define collector:set-first! false)
+(define collector:set-rest! false)
+
+(define (set-collector:deref! proc)
+  (set! collector:deref proc))
+
+(define (set-collector:alloc-flat! proc)
+  (set! collector:alloc-flat proc))
+
+(define (set-collector:cons! proc)
+  (set! collector:cons proc))
+
+(define (set-collector:first! proc)
+  (set! collector:first proc))
+
+(define (set-collector:rest! proc)
+  (set! collector:rest proc))
+
+(define (set-collector:flat?! proc)
+  (set! collector:flat? proc))
+
+(define (set-collector:cons?! proc)
+  (set! collector:cons? proc))
+
+(define (set-collector:set-first!! proc)
+  (set! collector:set-first! proc))
+
+(define (set-collector:set-rest!! proc)
+  (set! collector:set-rest! proc))

collects/plai/private/command-line.ss

@@ -0,0 +1,17 @@
+#lang scheme
+
+(provide disable-tests provide abridged-test-output gc-disable-import-gc?
+         alternate-collector set-alternate-collector!)
+
+
+;;; HACK!!!
+(define (alternate-collector)
+  (getenv "PLAI_ALTERNATE_COLLECTOR"))
+(define (set-alternate-collector! path)
+  (putenv "PLAI_ALTERNATE_COLLECTOR"
+          (if (path? path) (path->string path) path)))
+
+
+(define gc-disable-import-gc? (make-parameter false))
+(define disable-tests (make-parameter false))
+(define abridged-test-output (make-parameter false))

collects/plai/private/gc-core.ss

@@ -0,0 +1,182 @@
+#lang scheme
+(require
+ (for-syntax scheme))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Locations
+#|
+(provide wrapped-location?)
+(define-struct wrapped-location (location))
+
+(provide/contract (wrap-location (location? . -> . wrapped-location?)))
+(define (wrap-location loc)
+  (make-wrapped-location loc))
+
+(provide/contract (unwrap-location (wrapped-location? . -> . location?)))
+(define (unwrap-location wloc)
+  (wrapped-location-location wloc))
+|#
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Heap management
+(provide current-heap)
+(define current-heap (make-parameter false))
+
+(define (format-cell cell)
+  (let* ([str (format "~s" cell)]
+         [len (string-length str)])
+    (if (<= len 10)
+        (string-append str (build-string (- 10 len) (λ (_) #\space)))
+        (substring str 0 10))))
+
+;;; Textual representation of the heap
+(provide heap-as-string)
+(define (heap-as-string)
+  (let ([step 0])
+    (apply string-append
+           (for/list ([elt (in-vector (current-heap))])
+             (cond
+               [(= step 0) 
+                (begin
+                  (set! step (add1 step))
+                  (format-cell elt))]
+               [(= step 9) 
+                (begin
+                  (set! step 0)
+                  (string-append (format-cell elt) "\n"))]
+               [else
+                (begin
+                  (set! step (add1 step))
+                  (string-append " " (format-cell elt)))])))))
+
+;;; Predicate determines values that may be stored on the heap.  Limit this to "small" values that
+;;; conceptually occupy a small, fixed amount of space.  Closures are an exception.
+(provide/contract [heap-value? (any/c . -> . boolean?)])
+(define (heap-value? v)
+  (or (number? v) (symbol? v) (boolean? v) (empty? v) (procedure? v)))
+
+(provide location?)
+(define (location? v)
+  (if (vector? (current-heap))
+      (and (exact-nonnegative-integer? v) (< v (vector-length (current-heap))))
+      (error "Heap is unintialized")))
+
+(provide/contract (init-heap! (exact-nonnegative-integer? . -> . void?)))
+(define (init-heap! size)
+  (current-heap (build-vector size (λ (ix) false))))
+
+(provide/contract (heap-set! (location? heap-value? . -> . void?)))
+(define (heap-set! location value)
+  (vector-set! (current-heap) location value)
+  (when gui
+    (send gui update-view #:location location)))
+
+(provide/contract (heap-ref (location? . -> . heap-value?)))
+(define (heap-ref location)
+  (vector-ref (current-heap) location))
+
+(provide/contract (heap-size (-> (or/c false/c exact-nonnegative-integer?))))
+(define (heap-size)
+  (and (vector? (current-heap)) (vector-length (current-heap))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Root set management
+
+(provide gc-roots-key)
+(define gc-roots-key (gensym 'gc-roots-key))
+
+;;; Roots are defined with custom getters and setters as they can be created in various ways.
+(provide root? root-name make-root)
+(define-struct root (name get set!)
+  #:property prop:custom-write (λ (v port write?)
+                                 (display (format "#<root:~a>" (root-name v)) port)))
+
+(provide make-env-root)
+(define-syntax (make-env-root stx)
+  (syntax-case stx ()
+    [(_ id) (identifier? #'id)
+            #`(make-root 'id (λ () id) (λ (loc) (set! id loc)))]))
+
+;;; Roots on the stack.
+(provide/contract (stack-roots (-> (listof root?))))
+(define (stack-roots)
+  (filter is-mutable-root?
+          (apply append (continuation-mark-set->list (current-continuation-marks) gc-roots-key))))
+
+; An immutable root is a reference to a value or procedure in the Scheme heap.
+(define (is-mutable-root? root)
+  (location? ((root-get root))))
+
+(provide/contract (make-stack-root (symbol? location? . -> . root?)))
+(define (make-stack-root id location)
+  (make-root id (λ () location) (λ (new-location) (set! location new-location))))
+
+(provide/contract (read-root (root? . -> . location?)))
+(define (read-root root)
+  ((root-get root)))
+
+(provide/contract (set-root! (root? location? . -> . any)))
+(define (set-root! root loc)
+  ((root-set! root) loc))
+
+(provide/contract (get-global-roots (-> (listof root?))))
+(define (get-global-roots)
+  (filter is-mutable-root? global-roots))
+
+(define global-roots empty)
+
+(provide/contract (add-global-root! (root? . -> . void?)))
+(define (add-global-root! root)
+  (set! global-roots (cons root global-roots)))
+
+(provide get-root-set)
+(define-syntax (get-root-set stx)
+  (syntax-case stx ()
+    [(_ root-id ...)
+     (andmap identifier? (syntax->list #'(root-id ...)))
+     #`(begin
+         (append
+          (list (make-root 'root-id (λ () root-id) 
+                           (λ (loc) 
+                             (set! root-id loc)))
+                ...)
+          (get-global-roots)
+          (stack-roots)))]
+    [(_ e ...)
+     (let ([err (ormap (λ (x) (and (not (identifier? x)) x)) (syntax->list #'(e ...)))])
+       (raise-syntax-error false
+                           "expected an identifier to treat as a root"
+                           stx
+                           err))]
+    [_ (raise-syntax-error false
+                           "missing open parenthesis"
+                           stx)]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Environments of closures
+
+; Once the closure is garbage collected, its environment is only reachable by a weak reference to 
+; the closure.
+(define closure-envs (make-weak-hash))
+
+(provide/contract (add-closure-env! (procedure? (listof root?) . -> . any)))
+(define (add-closure-env! proc roots)
+  (hash-set! closure-envs proc roots))
+
+(provide/contract (get-closure-env (procedure? . -> . (or/c false/c (listof root?)))))
+(define (get-closure-env proc)
+  (hash-ref closure-envs proc false))
+
+(provide/contract (procedure-roots (procedure? . -> . (listof root?))))
+(define (procedure-roots proc)
+  (filter is-mutable-root? (hash-ref closure-envs proc empty)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Optional UI
+
+(provide set-ui!)
+(define (set-ui! ui%)
+  (set! gui (new ui% [heap-vec (current-heap)])))
+
+(define gui false)

collects/plai/private/gc-gui.ss

@@ -0,0 +1,447 @@
+#lang scheme/gui
+(require "gc-core.ss")
+(provide heap-viz%)
+
+(define row-size 10)
+
+(define heap-viz<%> (interface () update-view))
+
+(define horizontal-axis-height 0)
+(define vertical-axis-width 0)
+(define label-line-size 2)
+(define cell-horizontal-padding 6)
+(define cell-vertical-padding 4)
+(define vertical-axis-spacer 2)
+
+(define-struct arrow (from to) #:transparent)
+
+(define show-arrows? #t)
+(define show-highlighted-cells? #f)
+
+(define heap-canvas%
+  (class* canvas% (heap-viz<%>)
+    
+    (init-field heap-vec)
+  
+    (define column-widths (make-vector 
+                           (cond
+                             [(<= (vector-length heap-vec) 300) 10]
+                             [else 20])
+                           0))
+    (define row-heights (make-vector (ceiling (/ (vector-length heap-vec) 
+                                                 (vector-length column-widths)))
+                                     0))
+    
+    (define arrows '())
+    (define highlighted-cells '())
+    
+    (define/public (update-view)
+      (setup-min-width/height)
+      (redraw-offscreen)
+      (recompute-arrows-and-highlighted-cells)
+      (on-paint))
+
+    (inherit get-dc get-client-size refresh min-width min-height)
+    
+    (define/private (setup-min-width/height)
+      (fill-in-min-sizes)
+      (min-width (ceiling (inexact->exact (+ vertical-axis-width (vector-sum column-widths)))))
+      (min-height (ceiling (inexact->exact (+ horizontal-axis-height (vector-sum row-heights)))))
+      (compute-sizes))
+    
+    (define/private (compute-sizes)
+      (fill-in-min-sizes)
+      (let-values ([(w h) (get-client-size)])
+        
+        (define (distribute-extras sizes avail-size)
+          (let ([min-size (vector-sum sizes)])
+            (cond
+              [(< avail-size min-size) 
+               ;; just give up here; we'll draw outside the frame and get clipped
+               ;; could try to shrink the bigger columns or something, tho.
+               (void)]
+              [else
+               ;; distribute the extra width evenly to all the columns
+               (let ([extra-space (/ (- avail-size min-size)
+                                     (vector-length sizes))])
+                 (for ([i (in-range 0 (vector-length sizes))])
+                   (vector-set! sizes
+                                i
+                                (+ (vector-ref sizes i)
+                                   extra-space))))])))
+        
+        (distribute-extras column-widths (- w vertical-axis-width))
+        (distribute-extras row-heights (- h horizontal-axis-height))))
+        
+    (define/private (fill-in-min-sizes)
+      (let ([dc (get-dc)])
+        (let-values ([(w h d a) 
+                      (send dc get-text-extent (format "~a" (vector-length heap-vec)))])
+          (set! vertical-axis-width (+ w label-line-size vertical-axis-spacer)))
+        (let-values ([(w h d a) (send dc get-text-extent "1")])
+          (set! horizontal-axis-height (+ h label-line-size))))
+      
+      (for ([i (in-range 0 (vector-length heap-vec))])
+        (let ([column (remainder i (vector-length column-widths))]
+              [row (quotient i (vector-length column-widths))])
+          (let-values ([(cw ch) (cell-min-size (vector-ref heap-vec i))])
+            (vector-set! row-heights 
+                         row
+                         (max (+ ch cell-vertical-padding)
+                              (vector-ref row-heights row)))
+            (vector-set! column-widths 
+                         column
+                         (max (+ cw cell-horizontal-padding) 
+                              (vector-ref column-widths column)))))))
+    
+    (define/private (cell-min-size obj)
+      (let ([dc (get-dc)])
+        (let-values ([(w h d a) (send dc get-text-extent (val->string obj))])
+          (values w h))))
+    
+    (define/private (val->string obj)
+      (cond
+        [(boolean? obj) (if obj "#t" "#f")]
+        [(number? obj) (format "~a" obj)]
+        [(procedure? obj)
+         (if (object-name obj)
+             (format "~a" (object-name obj))
+             "#<proc>")]
+        [(symbol? obj) (format "'~s" obj)]
+        [(null? obj) "empty"]
+        [else (error 'val->string "unknown object, expected a heap-value.")]))
+    
+    (define/override (on-paint)
+      (unless offscreen (redraw-offscreen))
+      (let ([dc (get-dc)])
+        (send dc set-origin 0 0)
+        (send dc draw-bitmap offscreen 0 0)
+        (send dc set-origin vertical-axis-width horizontal-axis-height)
+        (for-each (λ (i) (draw-cell dc i #t))
+                  highlighted-cells)
+        (for-each (λ (arrow) (draw-arrow dc arrow))
+                  arrows)))
+    
+    (define offscreen #f)
+    
+    (define/private (redraw-offscreen)
+      (let-values ([(w h) (get-client-size)])
+        (when (or (not offscreen)
+                  (not (equal? w (send offscreen get-width)))
+                  (not (equal? h (send offscreen get-height))))
+          (set! offscreen (make-object bitmap% w h)))
+        (let ([dc (make-object bitmap-dc% offscreen)])
+          (send dc set-smoothing 'aligned)
+          (send dc clear)
+          
+          (send dc set-origin 0 0)
+          
+          ;; draw lines
+          (let-values ([(w h) (get-client-size)])
+            (send dc set-pen "navy" label-line-size 'solid)
+            (send dc draw-line 
+                  (- vertical-axis-width (/ label-line-size 2)) 0
+                  (- vertical-axis-width (/ label-line-size 2)) h)
+            (send dc draw-line 
+                  0 (- horizontal-axis-height (/ label-line-size 2))
+                  w (- horizontal-axis-height (/ label-line-size 2))))
+          
+          (send dc set-origin vertical-axis-width horizontal-axis-height)
+          
+          ;; draw x axis
+          (let ([y (- 0 horizontal-axis-height label-line-size)])
+            (for/fold ([x 0])
+              ([i (in-range 0 (vector-length column-widths))])
+              (let ([str (format "~a" i)])
+                (let-values ([(w h d a) (send dc get-text-extent str)])
+                  (setup-colors dc (+ i 1) 0 #f)
+                  (send dc draw-rectangle x y
+                        (vector-ref column-widths i)
+                        horizontal-axis-height)
+                  (send dc draw-text str 
+                        (+ x (- (/ (vector-ref column-widths i) 2)
+                                (/ w 2)))
+                        y)
+                  (+ x (vector-ref column-widths i))))))
+          
+          ;; draw y axis
+          (for/fold ([y 0])
+            ([i (in-range 0 (vector-length row-heights))])
+            (let ([str (format "~a" (* i (vector-length column-widths)))])
+              (let-values ([(w h d a) (send dc get-text-extent str)])
+                (let ([x (- 0 label-line-size w vertical-axis-spacer)])
+                  (setup-colors dc 0 (+ i 1) #f)
+                  (send dc draw-rectangle 
+                        (- vertical-axis-width)
+                        y 
+                        (- vertical-axis-width label-line-size)
+                        (vector-ref row-heights i))
+                  (send dc draw-text str 
+                        x
+                        (+ y (- (/ (vector-ref row-heights i) 2)
+                                (/ h 2))))
+                  (+ y (vector-ref row-heights i))))))
+          
+          ;; draw cells (this is O(n^2), but it seems unlikely to ever matter
+          ;; to fix, one would have to precompute the partial sums of the widths
+          ;; and heights of the columns)
+          (for ([i (in-range 0 (round-up-to-even-multiple 
+                                (vector-length heap-vec)
+                                (vector-length column-widths)))])
+            (draw-cell dc i #f))
+          
+          (send dc set-bitmap #f))))
+        
+    (define/private (draw-cell dc i highlighted?)
+      (let-values ([(cell-x cell-y cell-w cell-h) (cell->ltwh i)])
+        (let* ([column (remainder i (vector-length column-widths))]
+               [row (quotient i (vector-length column-widths))])
+          (setup-colors dc (+ column 1) (+ row 1) highlighted?)
+          (send dc draw-rectangle cell-x cell-y cell-w cell-h)
+          (when (< i (vector-length heap-vec))
+            (let-values ([(ow oh) (cell-min-size (vector-ref heap-vec i))])
+              (send dc draw-text 
+                    (val->string (vector-ref heap-vec i))
+                    (+ cell-x (- (/ cell-w 2) (/ ow 2)))
+                    (+ cell-y (- (/ cell-h 2) (/ oh 2)))))))))
+    
+    (define/private (draw-arrow dc arrow)
+      (let-values ([(fcell-x fcell-y fcell-w fcell-h) (cell->ltwh (arrow-from arrow))]
+                   [(tcell-x tcell-y tcell-w tcell-h) (cell->ltwh (arrow-to arrow))])
+        (let ([alpha (send dc get-alpha)])
+          (send dc set-alpha 2/3)
+          (send dc set-brush highlighted-color 'solid)
+          (send dc set-pen "black" 1 'transparent)
+          (send dc draw-ellipse 
+                (+ fcell-x (/ fcell-w 2) -4) 
+                (+ fcell-y (/ fcell-h 2) -4)
+                8 8)
+          (let-values ([(x y)
+                        (fill-in-arrow (+ fcell-x (/ fcell-w 2)) 
+                                       (+ fcell-y (/ fcell-h 2))
+                                       (+ tcell-x (/ tcell-w 2))
+                                       (+ tcell-y (/ tcell-h 2)))])
+            (send dc draw-polygon arrow-points)
+            (send dc set-pen highlighted-color 2 'solid)
+            (send dc draw-line 
+                  (+ fcell-x (/ fcell-w 2)) 
+                  (+ fcell-y (/ fcell-h 2))
+                  x y))
+          (send dc set-alpha alpha))))
+    
+    (define arrow-point1 (make-object point%))
+    (define arrow-point2 (make-object point%))
+    (define arrow-point3 (make-object point%))
+    (define arrow-points (list arrow-point1 arrow-point2 arrow-point3))
+    
+      ;; fill-in-arrow : number^ -> number number
+      ;; returns the end point for the line, so that the line
+      ;; doesn't cross over the arrow
+    
+    (define triangle-left (make-polar 1 (* pi 1/12)))
+    (define triangle-right (make-polar 1 (* pi -1/12)))
+    (define/private (fill-in-arrow sx sy ex ey)
+      (let* ([dir (make-polar 16
+                              (angle (- (make-rectangular sx (- sy))
+                                        (make-rectangular ex (- ey)))))]
+             [left-corner (* dir triangle-left)]
+             [right-corner (* dir triangle-right)]
+             [line-end-point (/ (+ left-corner right-corner) 2)])
+        (send arrow-point1 set-x ex)
+        (send arrow-point1 set-y ey)
+        (send arrow-point2 set-x (+ ex (real-part left-corner)))
+        (send arrow-point2 set-y (+ ey (- (imag-part left-corner))))
+        (send arrow-point3 set-x (+ ex (real-part right-corner)))
+        (send arrow-point3 set-y (+ ey (- (imag-part right-corner))))
+        (values (/ (+ (send arrow-point2 get-x) (send arrow-point3 get-x)) 2)
+                (/ (+ (send arrow-point2 get-y) (send arrow-point3 get-y)) 2))))
+        
+    (define (cell->ltwh i)
+      (let* ([column (remainder i (vector-length column-widths))]
+             [row (quotient i (vector-length column-widths))]
+             [cell-x (vector-sum column-widths column)]
+             [cell-y (vector-sum row-heights row)])
+        (values cell-x cell-y 
+                (vector-ref column-widths column)
+                (vector-ref row-heights row))))
+          
+    (define/override (on-size w h)
+      (compute-sizes)
+      (redraw-offscreen)
+      (refresh))
+    
+    (define/private (mouse-xy->ij mx my)
+      (define (find-index start vec m-coord)
+        (let loop ([coord start]
+                   [i 0])
+          (cond
+            [(< i (vector-length vec))
+             (cond
+               [(<= coord m-coord (+ coord (vector-ref vec i)))
+                i]
+               [else
+                (loop (+ coord (vector-ref vec i))
+                      (+ i 1))])]
+            [else #f])))
+      (values (find-index vertical-axis-width column-widths mx)
+              (find-index horizontal-axis-height row-heights my)))
+    
+    (define/override (on-event evt)
+      (cond
+        [(or (send evt moving?)
+             (send evt entering?))
+         (set! mouse-x (send evt get-x))
+         (set! mouse-y (send evt get-y))]
+        [else
+         (set! mouse-x #f)
+         (set! mouse-y #f)])
+      (recompute-arrows-and-highlighted-cells))
+    
+    (define mouse-x #f)
+    (define mouse-y #f)
+    
+    (define/private (recompute-arrows-and-highlighted-cells)
+      (cond
+        [(and mouse-x mouse-y)
+         (let-values ([(i j) (mouse-xy->ij mouse-x mouse-y)])
+           (if (and i j)
+               (let ([index (+ (* j (vector-length column-widths)) i)])
+                 (update-arrows (find-connections index))
+                 (update-highlighted-cells
+                  (cond
+                    [(< index (vector-length heap-vec))
+                     (cons index (index->nexts index))]
+                    [else '()])))
+               (update-highlighted-cells '())))]
+        [else
+         (update-highlighted-cells '())
+         (update-arrows '())]))
+
+    (define/private (index->nexts index)
+      (let ([n (vector-ref heap-vec index)])
+        (cond
+          [(and (exact-integer? n)
+                (<= 0 n)
+                (< n (vector-length heap-vec)))
+           (list n)]
+          [(procedure? n)
+           (map read-root (procedure-roots n))]
+          [else
+           '()])))
+    
+    (define/private (find-connections start)
+      (let ([visited (make-hash)]
+            [ans '()])
+        (let loop ([i start])
+          (unless (hash-ref visited i #f)
+            (hash-set! visited i #t)
+            (for-each
+             (λ (next) 
+               (set! ans (cons (make-arrow i next) ans))
+               (loop next))
+             (index->nexts i))))
+        ans))
+    
+    (define/private (update-arrows new)
+      (when show-arrows?
+        (unless (equal? new arrows)
+          (set! arrows new)
+          (refresh))))
+    
+    (define/private (update-highlighted-cells new)
+      (when show-highlighted-cells?
+        (unless (equal? new highlighted-cells)
+          (set! highlighted-cells new)
+          (refresh))))
+    
+    (super-new)
+    
+    (setup-min-width/height)
+    (send (get-dc) set-smoothing 'aligned)))
+
+(define (round-up-to-even-multiple n cols)
+  (let ([%% (remainder n cols)])
+    (cond
+      [(zero? %%) n]
+      [else (+ n (- cols %%))])))
+
+(define highlighted-color "forestgreen")
+
+(define (setup-colors dc i j highlighted-cell?)
+  (send dc set-pen "black" 1 'transparent)
+  (cond
+    [highlighted-cell?
+     (send dc set-brush highlighted-color 'solid)
+     (send dc set-text-foreground (send the-color-database find-color "white"))]
+    [else
+     (send dc set-brush (ij->background-color i j) 'solid)
+     (send dc set-text-foreground (send the-color-database find-color (ij->text-color i j)))]))
+
+(define (ij->background-color i j)
+  (cond
+    [(zero? i)
+     (if (zero? (modulo j 5))
+         "black"
+         "white")]
+    [(zero? j)
+     (if (zero? (modulo i 2)) 
+         "gray"
+         "white")]
+    [(zero? (modulo j 5))
+     "black"]
+    [(zero? (modulo i 2))
+     "gray"]
+    [else
+     "white"]))
+
+(define (ij->text-color i j)
+  (let ([bkg (ij->background-color i j)])
+    (cond
+      [(equal? bkg "black")
+       "white"]
+      [else 
+       "black"])))
+
+(define (vector-sum v [cap (vector-length v)])
+  (for/fold ((sum 0))
+    ((i (in-range cap)))
+    (+ sum (vector-ref v i))))
+    
+
+(define heap-viz%
+  (class* object% (heap-viz<%>)
+    (init heap-vec)
+    (define eventspace (make-eventspace))
+    (define frame
+      (parameterize ([current-eventspace eventspace])
+        (new frame% [label "Heap"])))
+    (define canvas (new heap-canvas% [parent frame] [heap-vec heap-vec] [style '(no-autoclear)]))
+    (new grow-box-spacer-pane% [parent frame])
+    (send frame show #t)
+    
+    ;; protects 'queued'
+    (define queued-sema (make-semaphore 1))
+    (define queued #f)
+    
+    (define/public (update-view #:location loc) 
+      (semaphore-wait queued-sema)
+      (cond
+        [queued
+         (semaphore-post queued-sema)]
+        [else
+         (set! queued #t)
+         (semaphore-post queued-sema)
+         (parameterize ([current-eventspace eventspace])
+           (queue-callback
+            (λ () 
+              (semaphore-wait queued-sema)
+              (set! queued #f)
+              (semaphore-post queued-sema)
+              ;; we might get others queued while this happens, but that seems ok
+              (send canvas update-view))
+            ;; low priority, so that mouse movements and window resizes
+            ;; take priority (important in the case that the mutator is 
+            ;; running a tight loop that changes the heap)
+            #f))]))
+            
+    (super-new)))

collects/plai/private/gc-transformer.ss

@@ -0,0 +1,20 @@
+#lang scheme
+
+(provide/contract (find-referenced-locals ((listof identifier?) syntax? . -> . (listof identifier?))))
+(define (find-referenced-locals env-ids stx)
+  (local ([define id-hash (make-custom-hash free-identifier=?
+                                            (λ (v) (equal-hash-code (syntax->datum v)))
+                                            (λ (v) (equal-secondary-hash-code (syntax->datum v))))]
+          [define (find stx)
+            (syntax-case stx ()
+              [(head . tail)
+               (begin
+                 (find #'head)
+                 (find #'tail))]
+              [id (identifier? stx)
+                  (begin
+                    (unless (dict-ref id-hash stx false)
+                    (dict-set! id-hash stx true)))]
+              [_ (void)])])
+    (find stx)
+    (filter (λ (env-id) (dict-ref id-hash env-id false)) env-ids)))

collects/plai/private/sandbox.ss

@@ -0,0 +1,88 @@
+#lang scheme
+(require scheme/sandbox)
+
+(define timeout/c (and/c integer? positive?))
+(define memory-limit/c (and/c integer? positive?))
+(define sandbox-result/c (or/c exn? (listof any/c)))
+(define eval-expression/c any/c)
+
+(define memory-accounting?
+  (custodian-memory-accounting-available?))
+
+(provide exn:fail:cpu-resource? exn:fail:cpu-resource-resource)
+(define-struct (exn:fail:cpu-resource exn:fail) (resource))
+
+
+(provide/contract
+ (call-with-limits/cpu-time
+  (timeout/c (-> any) . -> . any)))
+(define (call-with-limits/cpu-time sec thunk)
+  (let ([ch   (make-channel)]
+        ;; use this to copy parameter changes from the sub-thread
+        [p    current-preserved-thread-cell-values])
+    (let* ([start-cpu-time (current-process-milliseconds)]
+           ; cpu-time is modulo fixnum, so we may never reach end-cpu-time
+           [end-cpu-time (+ start-cpu-time (* 1000 sec))]
+           [work 
+            (thread (lambda ()
+                      (channel-put ch
+                                   (with-handlers ([void (lambda (e)
+                                                           (list (p) raise e))])
+                                     (call-with-values thunk
+                                                       (lambda vs (list* (p) values vs)))))))]
+           [watch (thread 
+                   (λ ()
+                     (channel-put 
+                      ch (let loop ([wait-sec 
+                                     (quotient 
+                                      (- end-cpu-time (current-process-milliseconds))
+                                      1000)])
+                           ; Wait for sec.  The process would have got < sec cpu-time.
+                           (sync/timeout wait-sec work)
+                           (if (>= (current-process-milliseconds) end-cpu-time)
+                               'time
+                               (loop (quotient 
+                                      (- end-cpu-time (current-process-milliseconds))
+                                      1000)))))))]
+           [r (channel-get ch)])
+      (kill-thread watch)
+      (if (list? r)
+          ;; apply parameter changes first
+          (begin (p (car r)) (apply (cadr r) (cddr r)))
+          (raise (make-exn:fail:cpu-resource "out of cpu time"
+                                             (current-continuation-marks)
+                                             r))))))
+
+
+(provide evaluate/limits/cpu-time)
+(define (evaluate/limits/cpu-time  evaluator memory-limit cpu-time-limit expr)
+  (parameterize ([sandbox-eval-limits `(#f ,memory-limit)])
+    (call-with-limits/cpu-time
+     cpu-time-limit
+     (λ () (evaluator expr)))))
+
+
+
+#|(provide/contract 
+   (sandbox-execution (timeout/c memory-limit/c eval-expression/c
+                                 . -> . sandbox-result/c)))|#
+
+(provide sandbox-execution)
+
+(define-struct (exn:sandbox:unknown exn:fail) (value))
+
+(define (sandbox-execution timeout memory-limit language requires body to-evaluate)
+  (with-handlers ([exn? (λ (exn) exn)]
+                  [(λ (x) #t) 
+                   (λ (v) 
+                     (make-exn:sandbox:unknown 
+                      v "not a subclass of exn:fail"
+                      (current-continuation-marks)))])
+    
+    (call-with-values
+     (λ ()
+       (parameterize ([sandbox-eval-limits `(,timeout ,memory-limit)])
+         (let ([evaluator (make-evaluator language requires body)])
+           (evaluator to-evaluate))))
+     (λ results results))))
+

collects/plai/private/test.ss

@@ -0,0 +1,9 @@
+#lang scheme
+(require plai/test-harness)
+
+(provide count-errors)
+(define (count-errors [results plai-all-test-results])
+  (foldl (λ (r n) 
+           (if (or (symbol=? (first r) 'bad) (symbol=? (first r) 'exception))
+               (+ n 1) n))
+         0 results))

collects/plai/private/tool-private.ss

@@ -0,0 +1,34 @@
+#lang scheme
+
+(provide plai-complete-program)
+(define (plai-complete-program port settings reader language-module)
+  (let ([state 'init])
+        ;; state : 'init => 'require => 'done
+    (lambda ()
+      (case state
+        [(init)
+         (set! state 'require)
+         (let ([body-exps 
+                (let loop ()
+                  (let ([result (reader (object-name port) port)])
+                    (if (eof-object? result)
+                        null
+                        (cons result (loop)))))])
+           (expand
+            (datum->syntax
+             #f
+             `(,#'module #%plai ,language-module
+                         ,@body-exps))))]
+        [(require) 
+         (set! state 'done)
+         (syntax
+          (let ([done-already? #f])
+            (dynamic-wind
+             void
+             (lambda ()
+               (dynamic-require ''#%plai #f))
+             (lambda () 
+               (unless done-already?
+                 (set! done-already? #t)
+                 (current-namespace (module->namespace ''#%plai)))))))]
+        [(done) eof]))))

collects/plai/random-mutator.ss

@@ -0,0 +1,294 @@
+#lang scheme/base
+(require scheme/pretty 
+         scheme/match 
+         scheme/contract
+         "private/gc-core.ss")
+
+(provide/contract
+ [save-random-mutator 
+  (->* (path-string?
+        string?)
+       (#:iterations 
+        exact-positive-integer?
+        #:heap-values (cons/c heap-value? (listof heap-value?))
+        #:program-size exact-positive-integer?
+        #:heap-size exact-positive-integer?)
+       void?)]
+ [find-heap-values
+  (-> (or/c path-string? input-port?)
+      (listof heap-value?))])
+
+;; graph : hash-table[number -o> obj]
+;; path : sexp
+;; result : flat-value
+(define-struct obj-graph (graph path result id) #:transparent)
+
+;; an obj is either:
+;;  - (make-terminal <constant>)
+;;  - (make-proc (listof ids))
+;;  - (make-pair id id)
+
+(define-struct terminal (const) #:transparent)
+(define-struct proc (ids) #:transparent)
+(define-struct pair (hd tl) #:transparent)
+
+(define (random-obj-graph size heap-values)
+  (let ([num-cells (+ 1 (random size))]
+        [hash (make-hash)])
+    (for ([i (in-range 0 num-cells)])
+      (hash-set! hash i (random-obj i num-cells size heap-values)))
+    (let-values ([(code last first-id) (random-path hash size)])
+      (make-obj-graph hash code last first-id))))
+
+(define (random-path hash size)
+  (let-values ([(first-terminal first-id) (pick-first hash)])
+    (let loop ([i (random size)]
+               [last-id first-id]
+               [codes '()])
+      (let ([done
+             (λ ()
+               (values 
+                (let loop ([codes (reverse codes)])
+                  (cond
+                    [(null? codes) (obj-num->id last-id)]
+                    [else ((car codes) (loop (cdr codes)))]))
+                (terminal-const first-terminal)
+                (obj-num->id last-id)))])
+        (cond
+          [(zero? i) (done)]
+          [else
+           (let ([next (find-connections-to hash last-id)])
+             (cond
+               [next (loop (- i 1)
+                           (connection-id next)
+                           (cons (connection-code next) codes))]
+               [else (done)]))])))))
+
+;; code : sexp -> sexp
+;; id : number 
+(define-struct connection (code id))
+
+;; find-connection-to : hash id -> connection or #f
+(define (find-connections-to hash id) 
+  (let ([candidate-code '()]
+        [candidate-ids '()])
+    (hash-for-each
+     hash
+     (λ (k v)
+       (cond
+         [(pair? v) 
+          (when (equal? id (pair-hd v))
+            (set! candidate-code (cons (λ (x) `(first ,x)) candidate-code))
+            (set! candidate-ids (cons k candidate-ids)))
+          (when (equal? id (pair-tl v))
+            (set! candidate-code (cons (λ (x) `(rest ,x)) candidate-code))
+            (set! candidate-ids (cons k candidate-ids)))]
+         [(terminal? v)
+          (void)]
+         [(proc? v)
+          (for ([proc-id (in-list (proc-ids v))]
+                [case-num (in-naturals)])
+            (when (equal? proc-id id)
+              (set! candidate-code (cons (λ (x) `(,x ,case-num)) candidate-code))
+              (set! candidate-ids (cons k candidate-ids))))])))
+    (cond
+      [(null? candidate-code)
+       #f]
+      [else
+       (let ([choice (random (length candidate-code))])
+         (make-connection (list-ref candidate-code choice)
+                          (list-ref candidate-ids choice)))])))
+  
+(define (pick-first hash)
+  (let ([candidate-terminals '()]
+        [candidate-ids '()])
+    (hash-for-each
+     hash
+     (λ (k v) 
+       (when (terminal? v)
+         (set! candidate-terminals (cons v candidate-terminals))
+         (set! candidate-ids (cons k candidate-ids)))))
+    (let ([choice (random (length candidate-terminals))])
+      (values (list-ref candidate-terminals choice)
+              (list-ref candidate-ids choice)))))
+
+(define (obj-graph->code obj-graph)
+  (let ([graph (obj-graph-graph obj-graph)]
+        [init-code '()])
+    (list 
+     `(define (build-one)
+        (let* (,@(build-list (hash-count graph)
+                             (λ (i) 
+                               (let-values ([(binding-code cell-init-code)
+                                             (obj->code i (hash-ref graph i))])
+                                 (set! init-code (append cell-init-code init-code)) 
+                                 `[,(obj-num->id i) ,binding-code]))))
+          ,@(reverse init-code)
+          ,(obj-graph-id obj-graph)))
+     `(define (traverse-one ,(obj-graph-id obj-graph))
+        ,(result->comparison (obj-graph-result obj-graph)
+                             (obj-graph-path obj-graph))))))
+
+(define (result->comparison expected-result exp)
+  (cond
+    [(number? expected-result) `(= ,expected-result ,exp)]
+    [(symbol? expected-result)
+     `(symbol=? ',expected-result ,exp)]
+    [(eq? expected-result #t)
+     `(let ([res ,exp])
+        (if (boolean? res)
+            res
+            #f))]
+    [(eq? expected-result #f) `(not ,exp)]
+    [(null? expected-result) `(empty? ,exp)]
+    [else (error 'result->comparison "unknown value ~s\n" expected-result)]))
+
+(define (obj-num->id x) (string->symbol (format "x~a" x)))
+
+(define proc-cases 5)
+
+;; random-obj : number obj -> (values sexp[constructor] (list sexp[init-code]))
+(define (obj->code cell-number obj)
+  (cond
+    [(terminal? obj) (values (terminal->code (terminal-const obj)) '())]
+    [(pair? obj)
+     (let* ([hd-direct? (< (pair-hd obj) cell-number)]
+            [tl-direct? (< (pair-tl obj) cell-number)]
+            [code0 (if hd-direct? 
+                       '()
+                       (list `(set-first! ,(obj-num->id cell-number)
+                                          ,(obj-num->id (pair-hd obj)))))]
+            [code1 (if tl-direct?
+                       code0
+                       (cons `(set-rest! ,(obj-num->id cell-number)
+                                         ,(obj-num->id (pair-tl obj)))
+                             code0))])
+       (values `(cons ,(if hd-direct?
+                           (obj-num->id (pair-hd obj))
+                           #f)
+                      ,(if tl-direct?
+                           (obj-num->id (pair-tl obj))
+                           #f))
+               code1))]
+    [(proc? obj)
+     (values `(lambda (x)
+                ,(let loop ([eles (proc-ids obj)]
+                            [i 0])
+                   (cond
+                     [(null? (cdr eles))
+                      (obj-num->id (car eles))]
+                     [else
+                      `(if (= x ,i)
+                           ,(obj-num->id (car eles))
+                           ,(loop (cdr eles) (+ i 1)))])))
+             '())]))
+
+(define (terminal->code const)
+  (cond
+    [(symbol? const) `',const]
+    [(null? const) 'empty]
+    [else const]))
+
+(define (random-obj cell-number num-cells size heap-values)
+  (case (random (if (zero? cell-number) 1 3))
+    [(0) (make-terminal (pick-from-list heap-values))]
+    [(1) (make-pair (random num-cells)
+                    (random num-cells))]
+    [(2) (make-proc (build-list (+ (random size) 1) (λ (i) (random cell-number))))]))
+
+(define (pick-from-list l) (list-ref l (random (length l))))
+
+(define (save-random-mutator filename collector 
+                             #:heap-values [heap-values (list 0 1 -1 'x 'y #f #t '())]
+                             #:iterations [iterations 200]
+                             #:program-size [program-size 10]
+                             #:heap-size [heap-size 200])
+  (call-with-output-file filename
+    (λ (port)
+      (cond
+        [collector
+         (fprintf port "#lang plai/mutator\n")
+         (fprintf port "~s\n" `(allocator-setup ,collector ,heap-size))
+         (fprintf port "~s\n" `(import-primitives symbol=?))]
+        [else
+         (fprintf port "#lang scheme\n")
+         (for-each
+          (λ (pair) (fprintf port "~s\n" `(define ,@pair)))
+          '((cons mcons)
+            (first mcar)
+            (rest mcdr)
+            (set-first! set-mcar!)
+            (set-rest! set-mcdr!)))])
+      (for-each (λ (x) (pretty-print x port))
+                (obj-graph->code (random-obj-graph program-size heap-values)))
+      (pretty-print `(define (trigger-gc n)
+                       (if (zero? n)
+                           0
+                           (begin 
+                             (cons n n)
+                             (trigger-gc (- n 1)))))
+                    port)
+      (pretty-print `(define (loop i)
+                       (if (zero? i)
+                           'passed
+                           (let ([obj (build-one)])
+                             (trigger-gc ,heap-size)
+                             (if (traverse-one obj)
+                                 (loop (- i 1))
+                                 'failed))))
+                    port)
+      (pretty-print `(loop ,iterations) port))
+    #:exists 'truncate))
+
+(define (find-heap-values in)
+  (cond
+    [(input-port? in)
+     (find-heap-values/main in)]
+    [else
+     (call-with-input-file in find-heap-values/main)]))
+
+(define (find-heap-values/main port)
+  (let* ([ht (make-hash)]
+         [exp (parameterize ([read-accept-reader #t])
+                (read port))]
+         [plai-collector-lang?
+          (match exp
+            [`(module ,name ,langname ,the-rest ...)
+             (and (regexp-match #rx"collector" (format "~s" langname))
+                  (regexp-match #rx"plai" (format "~s" langname)))]
+            [_ #f])])
+    (let loop ([exp exp]
+               [quoted? #f])
+      (match exp
+        [`',arg (loop arg #t)]
+        [``,arg (loop arg #t)]
+        [(? symbol?) 
+         (cond
+           [quoted? (hash-set! ht exp #t)]
+           [else
+            (case exp
+              [(true) (hash-set! ht #t #t)]
+              [(false) (hash-set! ht #f #t)]
+              [(null) (hash-set! ht '() #t)]
+              [(empty) (hash-set! ht '() #t)]
+              [else (void)])])]
+        [`() (when quoted?
+               (hash-set! ht '() #t))]
+        [(? heap-value?) (hash-set! ht exp #t)]
+        [(? list?)
+         (if (or quoted? (not plai-collector-lang?))
+             (for-each (λ (x) (loop x quoted?)) exp)
+             (match exp
+               [`(error ,skippable ,rest ...)
+                (for-each (λ (x) (loop x quoted?)) rest)]
+               [`(test ,a ,b)
+                (void)]
+               [`(test/exn ,a ,b)
+                (void)]
+               [else
+                (for-each (λ (x) (loop x quoted?)) exp)]))]
+        [else (void)]))
+    (sort (hash-map ht (λ (x y) x))
+          string<=?
+          #:key (λ (x) (format "~s" x)))))
+

collects/plai/scribblings/fake-collector.ss

@@ -0,0 +1,13 @@
+#lang scheme
+(provide (all-defined-out))
+
+(define init-allocator #f)
+(define gc:deref #f)
+(define gc:alloc-flat #f)
+(define gc:cons #f)
+(define gc:first #f)
+(define gc:rest #f)
+(define gc:set-first! #f)
+(define gc:set-rest! #f)
+(define gc:cons? #f)
+(define gc:flat? #f)

collects/plai/scribblings/fake-mutator.ss

@@ -0,0 +1,3 @@
+#lang scheme
+(provide (all-defined-out))
+(define-syntax allocator-setup #f)

collects/plai/scribblings/fake-web.ss

@@ -0,0 +1,3 @@
+#lang scheme
+(provide (all-defined-out))
+(define start #f)

collects/plai/scribblings/plai.scrbl

@@ -0,0 +1,584 @@
+#lang scribble/doc
+@(require scribble/manual
+          (for-syntax scheme)
+          (for-label (except-in scheme
+                                error printf)
+                     (prefix-in scheme:
+                                scheme)
+                     (only-in plai/main
+                              type-case define-type error
+                              test test/pred test/exn test/regexp
+                              abridged-test-output
+                              plai-catch-test-exn
+                              halt-on-errors print-only-errors test-inexact-epsilon plai-ignore-exn-strings plai-all-test-results)
+                     (only-in plai/collector
+                              root?
+                              heap-size
+                              location?
+                              heap-value?
+                              heap-set! heap-ref with-heap
+                              get-root-set read-root set-root!
+                              procedure-roots)
+                     plai/scribblings/fake-collector
+                     plai/scribblings/fake-mutator
+                     plai/scribblings/fake-web
+                     plai/random-mutator
+                     (only-in plai/web
+                              no-web-browser
+                              static-files-path)
+                     (only-in plai/mutator
+                              set-first!
+                              set-rest!
+                              import-primitives
+                              test/location=?
+                              test/value=?
+                              printf)))
+
+@(define-syntax-rule (schememodlang lang)
+   (scheme #,(hash-lang) lang))
+
+@(define PLAI-LANG "PLAI Scheme")
+@(define COLLECT-LANG "GC Collector Scheme")
+@(define MUTATE-LANG "GC Mutator Scheme")
+@(define WEB-LANG "Web Application Scheme")
+
+@title{@italic{Programming Languages: Application and Interpretation}}
+
+This is the documentation for the software accompanying the textbook @bold{Programming Languages: Application and
+Interpretation} (PLAI). The full book can be found on the Web at:
+
+@(link "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/"
+       "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/")
+
+In DrScheme, under the @onscreen{Language} menu, select @onscreen{Choose Language...}. Under the section @onscreen{Programming
+Languages: Application and Interpretation}, you will find the following languages:
+
+@itemize{
+  @item{@secref["plai-scheme"] - @schememodlang[plai]}
+  @item{@secref["collector"] - @schememodlang[plai/collector]}
+  @item{@secref["mutator"] - @schememodlang[plai/mutator]}
+  @item{@secref["web"] - @schememodlang[plai/web]}
+}
+
+@section[#:tag "plai-scheme"]{@PLAI-LANG} 
+
+@defmodulelang[plai]
+
+@(define scheme-guide '(lib "scribblings/reference/reference.scrbl"))
+
+@PLAI-LANG is derived from the @schememodname[scheme] langauge.  In addition, it includes
+the @scheme[define-type] and @scheme[type-case] forms and testing
+support.
+
+@subsection[#:tag "define-type"]{Defining Types: @scheme[define-type]}
+
+@defform/subs[(define-type type-id variant ...)
+              ([variant (variant-id (field-id contract-expr) ...)])]{
+
+Defines the datatype @scheme[_type-id].  A constructor @scheme[_variant-id] is defined for each variant.
+Each constructor takes an argument for each field of its variant.
+
+The value of each field is checked by its associated @scheme[_contract-expr].  A @scheme[_contract-expr] may be an
+arbitrary predicate or a contract.
+
+In addition to the contructors, a @scheme[define-type] expression also defines:
+
+@itemize{
+
+  @item{a predicate @scheme[_type-id?] that returns @scheme[true] for instances of the
+        datatype, and @scheme[false] for any other value,}
+
+  @item{for each variant, a predicate @scheme[_variant-id?] that returns @scheme[true] when applied to a value of the
+        same variant and @scheme[false] for any other value,}
+        
+  @item{for each field of each variant, an accessor @scheme[_variant-id-field-id] that returns the value of the
+         field, and}
+ 
+  @item{for each field of each variant, a mutator @scheme[_set-variant-id-field-id!] that set the value of the
+        field.}
+}
+}
+
+@subsection[#:tag "type-case"]{Deconstructing Data Structures: @scheme[type-case]}
+
+@defform/subs[(type-case datatype-id expr 
+                 branch ...)
+                 
+              ([branch (variant-id (field-id ...) result-expr ...)
+                       (else result-expr ...)])]{
+                       
+Branches on the datatype instance produced by @scheme[_expr], which must be an instance of @scheme[_datatype-id] 
+(previously defined with @scheme[define-type])  Each @scheme[_branch] extracts the values of the fields, and binds them
+to @scheme[_field-id ...].
+
+If a branch is not specified for each variant, you may use an @scheme[else] branch to create a catch-all branch.  An
+@scheme[else] branch must be the last branch in the sequence of branches.
+@scheme[type-case] signals a compile-time error if all variants are not covered and the @scheme[else] branch is
+missing.  Similarly, @scheme[type-case] signals a compile-time error if an @scheme[else] branch is unreachable because
+a branch exists for all variants.
+
+}
+         
+@subsection[#:tag "testing"]{Testing Infrastructure}
+
+PLAI Scheme provides the following syntactic forms for testing.
+
+@defform/subs[(test result-expr expected-expr)()]{
+
+If @scheme[_result-expr] and @scheme[_expected-expr] evaluate to the same value, @scheme[_result-value], the test prints
+
+@schemeresultfont{(good result-expr result-value expected-value location)}.
+
+If they do not evaluate to the same value, the test prints
+
+@schemeresultfont{(bad result-expr result-value expected-value location)}.
+
+If evaluating @scheme[_result-expr] signals an error, the test prints
+
+@schemeresultfont{(exception result-expr exception-message <no-expected-value> location)}
+
+If evaluating @scheme[_expected-expr] signals an error, the test prints
+
+@schemeresultfont{(pred-exception result-expr exception-message <no-expected-value> location)}
+
+}
+
+@defform/subs[(test/pred result-expr pred?)()]{
+
+Similar to @scheme[test], but instead of supplying an expected value, the predicate @scheme[_pred?] is applied to
+@scheme[_result-expr].
+
+If evaluating @scheme[_pred?] signals an error, the test prints
+
+@schemeresultfont{(pred-exception result-expr exception-message <no-expected-value> location)}
+
+The syntax of @scheme[_pred?] is considered @scheme[_expected-value] for the purposes of test reporting.
+}
+
+@defthing[error procedure?]{
+ Like @schememodname[scheme]'s @scheme[scheme:error],
+ but generates exceptions that are caught by @scheme[test/exn].
+}
+
+@defform/subs[(test/exn result-expr error-message)()]{
+
+This test succeeds if the expression evaluates to a call to @scheme[error]. Moreover, the error message contained in the
+exception must contain the string @scheme[_error-message]. Note that @scheme[test/exn] only suceeds if the exception was
+explicitly raised by the user.
+
+For example, the following test succeeds:
+
+@(schemeblock (test/exn (error "/: division by zero") "by zero")) 
+ 
+The error message is @scheme{/: division by zero}, and @scheme{by zero} is a substring of the error message. However,
+the following test fails:
+
+@(schemeblock (test/exn (/ 25 0) "by zero"))
+
+Although the expression raises an exception and the error string contains @scheme{by zero}, since the error was not
+explicitly raised by user-written code, the test fails.
+
+The evaluation of @scheme[_error-message] is considered @scheme[_expected-value] for the purposes of test reporting.
+}
+
+@defform/subs[(test/regexp result-expr error-message-regexp)()]{
+
+This test is similar to @scheme[test/exn],but the error message is matched against a regular expression instead.
+                        
+The evaluation of @scheme[_error-message-regexp] is considered @scheme[_expected-value] for the purposes of test reporting.
+}
+
+@subsubsection{Test Flags}
+
+@defproc[(abridged-test-output (abridge? boolean? false)) void?]{
+
+When this flag is set to @scheme[true], the test forms never prints @scheme[_result-expr] or @scheme[_location].
+     
+}
+
+@defproc[(plai-catch-test-exn (catch? boolean? true)) void?]{
+
+When this flag is set to @scheme[true], exceptions from tests will be caught.
+By default, exceptions are caught.
+
+}
+
+
+@defproc[(halt-on-errors (halt? boolean? true)) void?]{
+
+This flag determines whether the program immediately halts when a test fails.  By default, programs do not halt on
+failures.
+}
+
+@defproc[(print-only-errors (print? boolean? true)) void?]{
+
+When this flag is set to @scheme[true], only tests that fail will be printed.
+By default, the results of all tests are printed.
+
+}
+
+@defproc[(test-inexact-epsilon (epsilon number?)) void?]{
+
+When testing inexact values for equality, @scheme[test] permits them to differ by @scheme[_epsilon].  The
+default value of @scheme[_epsilon] is @scheme[0.01].
+
+}
+
+@defproc[(plai-ignore-exn-strings (ignore? boolean?)) void?]{
+
+If this flag is set to @scheme[true], when testing for exceptions with @scheme[test/exn] and @scheme[test/regexp],
+the message of the exception is ignored.  By default, @scheme[test/exn] and @scheme[test/regexp] only succeed when the
+message of the exception matches the supplied string or regular expression.
+
+}
+
+@defidform[plai-all-test-results]{
+
+This variable is the list of all tests that have been run so far, with the most recent test at the head.
+
+}
+      
+@section[#:tag "collector"]{@COLLECT-LANG} 
+
+@defmodulelang[plai/collector]
+
+@COLLECT-LANG is based on @seclink["plai-scheme"]{PLAI Scheme}.  It provides additional procedures and
+syntax for writing garbage collectors.
+
+@subsection{Garbage Collector Interface}
+
+The @COLLECT-LANG language provides the following functions that provide access to the heap and root set:
+
+@defproc[(heap-size) exact-nonnegative-integer?]{
+Returns the size of the heap.  The size of the heap is specified by the mutator that uses the garbage collector.
+See @scheme[allocator-setup] for more information.
+}
+
+@defproc[(location? [v any/c])
+         boolean?]{
+Determines if @scheme[v] is an integer between @scheme[0] and @scheme[(- (heap-size) 1)] inclusive.
+}
+
+@defproc[(root? [v any/c])
+         boolean?]{
+Determines if @scheme[v] is a root.
+}
+
+@defproc[(heap-value? [v any/c]) boolean?]{
+  A value that may be stored on the heap. Roughly corresponds to the contract @scheme[(or/c boolean? number? procedure? symbol? empty?)].
+}
+
+
+@defproc[(heap-set! (loc location?) (val heap-value?)) void?]{
+  Sets the value at @scheme[_loc] to @scheme[_val].
+}
+
+@defproc[(heap-ref (loc location?)) heap-value?]{
+  Returns the value at @scheme[_loc].
+}
+
+@defform/subs[(get-root-set id ...)()]{
+  Returns the current roots as a list.  Local roots are created for the identifiers @scheme[_id] as well. 
+}
+
+@defproc[(read-root (root root?)) location?]{
+  Returns the location of @scheme[_root].
+}
+
+@defproc[(set-root! (root root?) (loc location?)) void?]{
+  Updates the root to reference the given location.
+}
+
+@defproc[(procedure-roots (proc procedure?)) (listof root?)]{
+  Given a closure stored on the heap, returns a list of the roots reachable from the closure's environment.  If 
+  @scheme[_proc] is not reachable, the empty list is returned.
+}
+
+@defform[(with-heap heap expr ...)
+         #:contracts ([heap (vectorof heap-value?)])]{
+ Evaluates @scheme[(begin expr ...)] in the context of @scheme[heap]. Useful in tests:
+ @schemeblock[
+  (test (with-heap (make-vector 20) 
+          (init-allocator)
+          (gc:deref (gc:alloc-flat 2)))
+        2)
+  ]}
+
+@subsection{Garbage Collector Exports}
+
+@declare-exporting[#:use-sources (plai/scribblings/fake-collector)]
+
+A garbage collector must define the following functions:
+
+@defproc[(init-allocator) void?]{
+
+@scheme[init-allocator] is called before all other procedures by a mutator. Place any requisite initialization code
+here.
+  
+}
+
+@defproc[(gc:deref (loc location?)) heap-value?]{
+
+Given the location of a flat Scheme value, this procedure should return that value.  If the location does not hold
+a flat value, this function should signal an error.
+
+}
+
+@defproc[(gc:alloc-flat (val heap-value?)) location?]{
+
+This procedure should allocate a flat Scheme value (number, symbol, boolean, closure or empty list) on the heap,
+returning its location (a number). The value should occupy a single heap cell, though you may use additional space to
+store a tag, etc. You are also welcome to pre-allocate common constants (e.g., the empty list). This procedure may need
+to perform a garbage-collection. If there is still insufficient space, it should signal an error.
+
+Note that closures are flat values. The environment of a closure is internally managed, but contains
+references to values on the heap. Therefore, during garbage collection, the environment of reachable closures must be
+updated. The language exposes the environment via the @scheme[procedure-roots] function.
+
+}
+
+@defproc[(gc:cons (first location?) (rest location?)) location?]{
+
+Given the location of the @scheme[_first] and @scheme[_rest] values, this procedure must allocate a cons cell on the 
+heap.  If there is insufficient space to allocate the cons cell, it should signal an error.
+
+}
+
+@defproc[(gc:first (cons-cell location?)) location?]{
+
+If the given location refers to a cons cell, this should return the first field. Otherwise, it should signal an error.
+
+}
+
+@defproc[(gc:rest (cons-cell location?)) location?]{
+
+If the given location refers to a cons cell, this should return the rest field. Otherwise, it should signal an error.
+
+}
+
+@defproc[(gc:set-first! (cons-cell location?) (first-value location?)) void?]{
+
+If @scheme[_cons-cell] refers to a cons cell, set the head of the cons cell to
+@scheme[_first-value].  Otherwise, signal an error.
+
+}
+
+@defproc[(gc:set-rest! (cons-cell location?) (rest-value location?)) void?]{
+
+If @scheme[_cons-cell] refers to a cons cell, set the tail of the cons cell to
+@scheme[_rest-value].  Otherwise, signal an error.
+
+}
+
+@defproc[(gc:cons? (loc location?)) boolean?]{
+
+
+Returns @scheme[true] if @scheme[_loc] refers to a cons cell.  This function should never signal an error.
+
+}
+
+@defproc[(gc:flat? (loc location?)) boolean?]{
+
+Returns @scheme[true] if @scheme[_loc] refers to a flat value.  This function should never signal an error.
+
+}
+
+@section[#:tag "mutator"]{@MUTATE-LANG}
+
+@defmodulelang[plai/mutator]
+
+The @MUTATE-LANG language is used to test garbage collectors written with the 
+@secref["collector"] language.  Since collectors support a subset of Scheme's values, the @MUTATE-LANG language supports a subset of procedures and syntax.
+In addition, many procedures that can be written in the mutator are omitted as they make good test cases.  Therefore,
+the mutator language provides only primitive procedures, such as @scheme[+], @scheme[cons], etc.
+
+@subsection{Building Mutators}
+
+@declare-exporting[#:use-sources (plai/scribblings/fake-mutator)]
+
+The first expression of a mutator must be:
+
+@defform/subs[
+(allocator-setup collector-module 
+                 heap-size)
+([heap-size exact-nonnegative-integer?])]{
+
+@scheme[_collector-module] specifies the path to the garbage collector that the mutator should use.  The collector
+must be written in the @COLLECT-LANG language.
+}
+
+The rest of a mutator module is a sequence of definitions, expressions and test cases. The @MUTATE-LANG language
+transforms these definitions and statements to use the collector specified in @scheme[allocator-setup].  In particular,
+many of the primitive forms, such as @scheme[cons] map directly to procedures such as @scheme[gc:cons], written in the
+collector.
+
+@subsection{Mutator API}
+
+The @MUTATE-LANG language supports the following syntactic forms:
+
+@schemeblock[if and or cond case define define-values let let-values let* set! lambda λ quote error begin]
+
+The language also defines the following procedures:
+
+@schemeblock[add1 sub1 zero? + - * / even? odd? = < > <= >= cons first rest
+             set-first! set-rest! cons? symbol? symbol=? number? boolean? empty? eq?]
+
+@defproc[(set-first! [c cons?] [v any/c])
+         void]{
+ Sets the @scheme[first] of the cons cell @scheme[c].
+}
+
+@defproc[(set-rest! [c cons?] [v any/c])
+         void]{
+ Sets the @scheme[rest] of the cons cell @scheme[c].
+}
+
+The identifier @scheme[empty] is defined to invoke @scheme[(gc:alloc-flat empty)] wherever it is used.
+
+Other common procedures are left undefined as they can be defined in
+terms of the primitives and may be used to test collectors.
+
+Additional procedures from @schememodname[scheme] may be imported with:
+
+@defform/subs[(import-primitives id ...)()]{
+
+Imports the procedures @scheme[_id ...] from @schememodname[scheme].  Each
+procedure is transformed to correctly interface with the mutator.  That is, its
+arguments are dereferenced from the mutator's heap and the result is allocated
+on the mutator's heap.  The arguments and result must be @scheme[heap-value?]s,
+even if the imported procedure accepts or produces structured data.
+
+For example, the @MUTATE-LANG language does not define @scheme[modulo]:
+
+@schemeblock[
+
+(import-primitives modulo)
+
+(test/value=? (modulo 5 3) 2)
+]
+
+}
+
+@subsection{Testing Mutators}
+
+@MUTATE-LANG provides two forms for testing mutators:
+
+@defform/subs[(test/location=? mutator-expr1 mutator-expr2)()]{
+
+@scheme[test/location=?] succeeds if @scheme[_mutator-expr1] and @scheme[_mutator-expr2] reference the same location
+on the heap.
+ 
+}
+
+@defform/subs[(test/value=? mutator-expr scheme-datum/quoted)()]{
+
+@scheme[test/value=?] succeeds if @scheme[_mutator-expr] and @scheme[_scheme-datum/expr] are structurally equal.
+@scheme[_scheme-datum/quoted] is not allocated on the mutator's heap. Futhermore, it must either be a quoted value or a
+literal value.
+
+}
+
+@defform/subs[
+(printf format mutator-expr ...)
+([format literal-string])]{
+
+In @|MUTATE-LANG|, @scheme[printf] is a syntactic form and not a procedure. The format string,
+@scheme[_format] is not allocated on the mutator's heap.
+
+}
+
+@section[#:tag "web"]{@WEB-LANG}
+
+@defmodulelang[plai/web]
+
+The @WEB-LANG language allows you to write server-side Web applications for the PLT Web Server.
+
+For more information about writing Web applications, see:
+@other-manual['(lib "web-server/scribblings/web-server.scrbl")].
+
+When you click on the @onscreen{Run} button in DrScheme, your Web application is launched in the Web server.
+
+The application is available at @italic{http://localhost:8000/servlets/standalone.ss}. 
+
+The @WEB-LANG language will automatically load this URL in your Web browser.
+
+You may use @scheme[no-web-browser] to prevent the browser from being launched and @scheme[static-files-path]
+to serve additional static files.
+
+@subsection{Web Application Exports}
+
+@declare-exporting[#:use-sources (plai/scribblings/fake-web)]
+
+A Web application must define a procedure @scheme[start]: 
+
+@defproc[(start (initial-request request?)) response?]{
+
+The initial request to a Web application is serviced by this procedure.
+
+}
+
+@section{Generating Random Mutators}
+
+@defmodule[plai/random-mutator]
+
+This PLAI library provides a facility for generating random mutators,
+in order to test your garbage collection implementation.
+
+@defproc[(save-random-mutator 
+          [file path-string?]
+          [collector-name string?]
+          [#:heap-values heap-values (cons heap-value? (listof heap-value?)) (list 0 1 -1 'x 'y #f #t '())]
+          [#:iterations iterations exact-positive-integer? 200] 
+          [#:program-size program-size exact-positive-integer? 10]
+          [#:heap-size heap-size exact-positive-integer? 100])
+         void?]{
+Creates a random mutator that uses the collector @scheme[collector-name] and
+saves it in @scheme[file].
+
+The mutator is created by first making a random graph whose nodes either
+have no outgoing edges, two outgoing edges, or some random number of 
+outgoing edges and then picking
+a random path in the graph that ends at one of the nodes with no edges.
+
+This graph and path are then turned into a PLAI program by creating
+a @scheme[let] expression that binds one variable per node in the graph.
+If the node has no outgoing edges, it is bound to a @scheme[heap-value?].
+If the node has two outgoing edges, it is bound to a pair and the two
+edges are put into the first and rest fields. Otherwise, the node
+is represented as a procedure that accepts an integer index and 
+returns the destination node of the corresponding edge.
+
+Once the @scheme[let] expression has been created, the program
+creates a bunch of garbage and then traverses the graph, 
+according to the randomly created path. If the result of the path
+is the expected heap value, the program does this again, up
+to @scheme[iterations] times. If the result of the path
+is not the expected heap value, the program terminates
+with an error.
+
+The keyword arguments control some aspects of the generation
+of random mutators:
+@itemize[@item{Elements from the @scheme[heap-values] argument are used
+               as the base values when creating nodes with no outgoing edges.
+               See also @scheme[find-heap-values].}
+          @item{The @scheme[iterations] argument controls how many times
+                the graph is created (and traversed).}
+          @item{The @scheme[program-size] argument is a bound on how
+                big the program it is; it limits the number of nodes,
+                the maximum number of edges, and the length of the 
+                path in the graph.}
+          @item{The @scheme[heap-size] argument controls the size of the
+                heap in the generated mutator.}]
+
+}
+               
+
+@defproc[(find-heap-values [input (or/c path-string? input-port?)]) (listof heap-value?)]{
+  Processes @scheme[input] looking for occurrences of @scheme[heap-value?]s
+  in the source of the program and returns them. This makes a good start
+  for the @scheme[heap-values] argument to @scheme[save-random-mutator].
+  
+  If @scheme[input] is a port, its contents are assumed to be a well-formed 
+  PLAI program. If @scheme[input] is a file, the contents of the file are 
+  used.
+}

collects/plai/test-harness.ss

@@ -0,0 +1,208 @@
+#lang scheme
+(require (only-in srfi/13 string-contains)
+         plai/private/command-line)
+
+(provide plai-error test test/pred test/regexp test/exn)
+(provide/contract
+ [exn:plai? (any/c . -> . boolean?)]
+ [abridged-test-output (parameter/c boolean?)]
+ [plai-ignore-exn-strings (parameter/c boolean?)]
+ [plai-catch-test-exn (parameter/c boolean?)]
+ [test-inspector (parameter/c inspector?)]
+ [test-inexact-epsilon (parameter/c number?)])
+
+(define thunk (-> any))
+
+(define test-inspector (make-parameter (current-inspector)))
+(define test-inexact-epsilon (make-parameter 0.01))
+
+; We only catch exceptions of this type.  plai-error throws such exceptions.
+(define-struct (exn:plai exn:fail) () #:transparent)
+
+(define (plai-error . args)
+  (with-handlers
+      [(exn:fail? (λ (exn) 
+                    (raise
+                     (make-exn:plai (exn-message exn)
+                                    (exn-continuation-marks exn)))))]
+    (apply error args)))
+
+(define-struct (exn:test exn:fail) ())
+
+(define (install-test-inspector)
+  (test-inspector (current-inspector))
+  (current-inspector (make-inspector))
+  (print-struct #t))
+
+(define (maybe-command-line arg)
+  (and (member arg (vector->list (current-command-line-arguments))) true))
+
+(define halt-on-errors? (maybe-command-line "--plai-halt-on-errors"))
+(define print-only-errors? (maybe-command-line "--plai-print-only-errors"))
+
+(provide/contract (halt-on-errors (() (boolean?) . ->* . void?)))
+(define (halt-on-errors [halt? true])
+  (set! halt-on-errors? halt?))
+
+(provide/contract (print-only-errors (() (boolean?) . ->* . void?)))
+(define (print-only-errors [print? true])
+  (set! print-only-errors? print?))
+
+; list of all test results
+(provide plai-all-test-results)
+(define plai-all-test-results empty)
+
+; set to true if 
+(define plai-ignore-exn-strings (make-parameter false))
+
+(define (may-print-result result)
+  (parameterize ([current-inspector (test-inspector)]
+                 [print-struct #t])
+    (define error? 
+      (not (eq? (first result) 'good)))
+    (define print?
+      (if print-only-errors?
+          (if error?
+              #t
+              #f)
+          #t))
+    (set! plai-all-test-results (cons result plai-all-test-results))
+    (when print?
+      (write result) (newline))
+    (when (and halt-on-errors? error?)
+      (raise (make-exn:test (string->immutable-string (format "test failed: ~s" result))
+                            (current-continuation-marks))))))
+
+(define plai-catch-test-exn (make-parameter true))
+(define (exn+catching? x)
+  (and (exn? x) (plai-catch-test-exn)))
+
+;;; If the expression raises an exception, it is returned as a value, only if
+;;; the exception subclasses struct:exn.
+(define-syntax (return-exception stx)
+  (syntax-case stx ()
+    [(_ expr)
+     #'(with-handlers
+           ([exn+catching? (λ (exn) exn)])
+         expr)]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Syntax forms for the test procedures make it unnecessary to enclose the
+;;; expression in a thunk.  More importantly, they automatically specify the
+;;; line number of the test as the comment.
+
+(provide generic-test)
+(define (abridged v)
+  (if (abridged-test-output)
+      empty
+      (list v)))
+(define (print-error case test-sexp test-result expected-val loc)
+  `(,case
+    ,@(abridged test-sexp)
+    ,test-result
+    ,expected-val
+    ,@(abridged loc)))
+
+(define (generic-test test-thunk pred test-sexp loc)
+  (unless (disable-tests)
+    (may-print-result
+     (with-handlers
+         ; Applying the predicate shouldn't raise an exception.
+         ([exn+catching? (λ (exn) 
+                  (print-error
+                   'pred-exception
+                   test-sexp
+                   (exn-message exn)
+                   '<no-expected-value>
+                   loc))])
+       (let ([test-result (return-exception (test-thunk))])
+         (if (or (exn:plai? test-result)
+                 (not (exn? test-result)))
+             (local [(define-values (test-value expected-val)
+                       (pred test-result))]
+               (print-error 
+                (cond
+                  [(exn:plai? test-value) 'exception]
+                  [test-value 'good]
+                  [else 'bad]) 
+                test-sexp
+                (if (exn:plai? test-result)
+                    (exn-message test-result)
+                    test-result)
+                expected-val loc))
+             (print-error
+              'exception
+              test-sexp
+              (exn-message test-result)
+              '<no-expected-value>
+              loc)))))))
+
+(define (equal~? x y)
+  (or (parameterize ([current-inspector (test-inspector)])
+        (equal? x y))
+      (and (number? x) (number? y)
+           (or (inexact? x) (inexact? y))
+           ; If one of them is inexact, we do the math.
+           (< (abs (- x y)) (test-inexact-epsilon)))))
+
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ result-expr expected-expr)
+     #`(generic-test 
+        (λ () result-expr) 
+        (λ (result-value)
+          (define expected-val expected-expr)
+          (values
+           (cond
+             [(exn:plai? result-value) result-value]
+             [(equal~? result-value expected-val) true]
+             [else false])
+           expected-val))
+        (quote #,(syntax->datum #'result-expr))
+        (format "at line ~a" #,(syntax-line stx)))]))
+
+(define-syntax (test/pred stx)
+  (syntax-case stx ()
+    [(_ test-expr pred)
+     #`(generic-test 
+        (λ () test-expr)
+        (λ (val)
+          (values
+           (cond
+             [(exn:plai? val) val]
+             [else (pred val)])
+           (quote #,(syntax->datum #'pred))))
+        (quote #,(syntax->datum #'test-expr))
+        (format "at line ~a" #,(syntax-line stx)))]))
+
+(define-syntax (test/exn stx)
+  (syntax-case stx ()
+    [(_ test-expr exception-substring)
+     #`(generic-test
+        (λ () test-expr)
+        (λ (val)
+          (define exception-substring-val exception-substring)
+          (values
+           (and (exn:plai? val)
+                (or (plai-ignore-exn-strings)
+                    (string-contains (exn-message val) exception-substring-val)))
+           exception-substring-val))
+        (quote #,(syntax->datum #'test-expr))
+        (format "at line ~a" #,(syntax-line stx)))]))
+
+(define-syntax (test/regexp stx)
+  (syntax-case stx ()
+    [(_ test-expr regexp)
+     #`(generic-test
+        (λ () test-expr)
+        (λ (val)
+          (define regexp-val regexp)
+          (values 
+           (and (exn:plai? val)
+                (or (plai-ignore-exn-strings)
+                    (regexp-match regexp (exn-message val))))
+           regexp-val))
+        (quote #,(syntax->datum #'test-expr))
+        (format "at line ~a" #,(syntax-line stx)))]))
+
+(install-test-inspector)

collects/plai/web.ss

@@ -0,0 +1,15 @@
+#lang scheme
+(require plai/datatype
+         plai/test-harness
+         web-server/servlet
+         (prefix-in insta: web-server/insta/insta))
+
+(provide (all-from-out plai/datatype)
+         (all-from-out web-server/servlet)
+         (except-out (all-from-out scheme) error #%module-begin)
+         (except-out (all-from-out plai/test-harness) plai-error)
+         (rename-out [plai-error error]
+                     [insta:no-web-browser no-web-browser]
+                     [insta:static-files-path static-files-path] 
+                     [insta:#%module-begin #%module-begin]))
+

collects/plai/web/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  #:language `plai/web)

collects/tests/plai/all.scm

@@ -1,37 +0,0 @@
-(define-type AE
-  [num (n number?)]
-  [add (lhs AE?)
-       (rhs AE?)]
-  [sub (lhs AE?)
-       (rhs AE?)])
-
-;; calc : AE -> number
-;; to define a calculator for AEs
-
-(define (calc an-ae)
-  (type-case AE an-ae
-             [num (n) n]
-             [add (l r) (+ (calc l) (calc r))]
-             [sub (l r) (- (calc l) (calc r))]))
-
-(test (calc (num 3)) 3)
-(test (calc (add (num 3) (num 4))) 7)
-(test (calc (add (sub (num 3) (num 4)) (num 7))) 6)
-
-;; parse : sexp -> AE
-;; to convert s-expressions into AEs
-
-(define (parse sexp)
-  (cond
-   [(number? sexp) (num sexp)]
-   [(cons? sexp)
-    (case (first sexp)
-      [(+) (add (parse (second sexp))
-                     (parse (third sexp)))]
-      [(-) (sub (parse (second sexp))
-                     (parse (third sexp)))])]))
-
-(test (calc (parse 3)) 3)
-(test (calc (parse (list '+ 3 4))) 7)
-(test (calc (parse (list '+ (list '- 3 4) 7))) 6)
-

collects/tests/plai/arith-interp.scm

@@ -1,17 +0,0 @@
-(define-type AE
-  [num (n number?)]
-  [add (lhs AE?)
-       (rhs AE?)])
-
-;; calc : AE -> number
-;; to define a calculator for AEs
-
-(define (calc an-ae)
-  (type-case AE an-ae
-             [num (n) n]
-             [add (l r) (+ (calc l) (calc r))]))
-
-(test (calc (num 3)) 3)
-(test (calc (add (num 3) (num 4))) 7)
-(test (calc (add (add (num 3) (num 4)) (num 7))) 14)
-

collects/tests/plai/datatype-test.ss

@@ -1,111 +0,0 @@
-(module datatype-test mzscheme
-  (require plai/datatype
-           plai/test-harness
-           mzlib/contract)
-  
-  (print-tests 'stop)
-  
-  ;; TODO:
-  ;; ? Make sure the contract expressions are only evaluated once
-  ;; - Test that helpful error messages are generated
-  
-  (define-type (Option a)
-    [Some (item a)]
-    [None])
-  
-  (define-type (List a)
-      [Cons (item a) (rest (List-of/c a))]
-      [Nil])
-  
-  (define-type (TreeMap a b)
-    [RedNode (left (TreeMap-of/c a b)) (key a) (val b) (right (TreeMap-of/c a b))]
-    [BlackNode (left (TreeMap-of/c a b)) (key a) (val b) (right (TreeMap-of/c a b))]
-    [Leaf])
-  
-  (define-type (a-List a)
-    [a-Cons (item a) (rest (b-List-of/c a))]
-    [a-Nil])
-  
-  (define-type (b-List b)
-    [b-Cons (item b) (rest (a-List-of/c b))]
-    [b-Nil])
-  
-  ;; Error Messages
-  (test/exn (lambda () (expand #'(define-type (BadOption a)
-                                  [Some (item a)]
-                                  [Some (item a)])))
-            "duplicate")
-  
-  (test/exn (lambda () (expand #'(define-type (BadList 123)
-                                   [Cons (item a) (rest (BadList-of/c a))]
-                                   [Nil])))
-            "expected an identifier")
-  
-  ;; Option Test
-  (test/pred (Some 1) Option?)
-  (test/pred (Some 1) Some?)
-  (test/pred (None) Option?)
-  (test/pred (None) None?)
-  
-  (test ((Some-of integer?) 1) (Some 1))
-  (test (contract (Option-of/c integer?) (Some 1) 'p 'n) (Some 1))
-  (test (contract (Some-of/c integer?) (Some 1) 'p 'n) (Some 1))
-  
-  (test ((None-of integer?)) (None))
-  (test (contract (Option-of/c integer?) (None) 'p 'n) (None))
-  (test (contract (None-of/c symbol?) (None) 'p 'n) (None))
-  
-  (test (Some-item (Some 1)) 1) 
-  
-  (test/exn (lambda () ((Some-of integer?) 'a)) "broke the contract")
-  (test/exn (lambda () (contract (Some-of/c integer?) (Some 'symbol) 'p 'n)) "broke the contract")
-  (test/exn (lambda () (contract (Option-of/c integer?) (Some 'symbol) 'p 'n)) "broke the contract") 
-  
-  ;; List Test
-  (test/pred (Nil) List?)
-  (test/pred (Nil) Nil?)
-  (test/pred (Cons 1 (Nil)) List?)
-  (test/pred (Cons 1 (Nil)) Cons?)
-  
-  (test ((Cons-of integer?) 1 (Cons 2 (Cons 3 (Nil))))
-        (Cons 1 (Cons 2 (Cons 3 (Nil)))))
-  (test (contract (List-of/c integer?) (Cons 1 (Cons 2 (Cons 3 (Nil)))) 'p 'n)
-        (Cons 1 (Cons 2 (Cons 3 (Nil)))))
-  (test (contract (Cons-of/c integer?) (Cons 1 (Cons 2 (Cons 3 (Nil)))) 'p 'n)
-        (Cons 1 (Cons 2 (Cons 3 (Nil)))))
-
-  (test ((Nil-of integer?)) (Nil))
-  (test (contract (List-of/c integer?) (Nil) 'p 'n) (Nil))
-  (test (contract (Nil-of/c integer?) (Nil) 'p 'n) (Nil))
-  
-  (test/exn (lambda () ((Cons-of integer?) 1 2)) "broke the contract") 
-  (test/exn (lambda () (contract (Cons-of/c integer?) (Cons 1 2) 'p 'n)) "broke the contract")
-  (test/exn (lambda () ((Cons-of integer?) 1 (Cons 2 (Cons 'symbol (Nil))))) "broke the contract")
-  
-  ;; TreeMap Test
-  (test/pred (Leaf) TreeMap?)
-  (test/pred (Leaf) Leaf?)
-  (test/pred (RedNode (Leaf) 1 2 (Leaf)) TreeMap?)
-  (test/pred (RedNode (Leaf) 1 2 (Leaf)) RedNode?)
-  (test/pred (BlackNode (Leaf) 1 2 (Leaf)) TreeMap?)
-  (test/pred (BlackNode (Leaf) 1 2 (Leaf)) BlackNode?)
-  
-  ;; Alternating List Test
-  (test/pred (a-Nil) a-List?)
-  (test/pred (a-Nil) a-Nil?)
-  (test/pred (b-Nil) b-List?)
-  (test/pred (b-Nil) b-Nil?)
-  (test/pred (a-Cons 1 (b-Nil)) a-List?)
-  (test/pred (a-Cons 1 (b-Nil)) a-Cons?)
-  (test/pred (b-Cons 1 (a-Nil)) b-List?)
-  (test/pred (b-Cons 1 (a-Nil)) b-List?)
-  
-  (test ((a-Cons-of integer?) 1 (b-Nil)) (a-Cons 1 (b-Nil)))
-  (test (contract (a-List-of/c integer?) (a-Cons 1 (b-Nil)) 'p 'n) (a-Cons 1 (b-Nil)))
-  (test (contract (a-Cons-of/c integer?) (a-Cons 1 (b-Nil)) 'p 'n) (a-Cons 1 (b-Nil)))
-  (test ((b-Cons-of integer?) 1 (a-Nil)) (b-Cons 1 (a-Nil)))
-  (test (contract (b-List-of/c integer?) (b-Cons 1 (a-Nil)) 'p 'n) (b-Cons 1 (a-Nil)))
-  (test (contract (b-Cons-of/c integer?) (b-Cons 1 (a-Nil)) 'p 'n) (b-Cons 1 (a-Nil)))
-  
-  (test/exn (lambda () ((a-Cons-of integer?) 1 (a-Nil))) "broke the contract")
-  )

collects/tests/plai/datatype.ss

@@ -0,0 +1,39 @@
+#lang plai
+(define-type A
+  [mta]
+  [a (b B?)])
+
+(define-type B
+  [mtb]
+  [b (a A?)])
+
+(define-type T
+  [i (f number?)])
+
+(i 4)
+(test/exn (make-i #f) "contract")
+(test/exn (i-f #f) "contract")
+
+(define-type T1
+  [i1 (f (car 1))])
+
+(type-case A (mta)
+           [mta () 1]
+           [a (x) 2])
+
+(define-type DefrdSub
+  [mtSub]
+  [aSub (value boolean?)])
+
+(define (lookup ds the-name)
+  (type-case DefrdSub ds
+             [mtSub () 1]
+             [aSub (a-name) 2]))
+
+(define-type t (c))
+(test/exn
+ (type-case t (list 1) (c () 1))
+ "expected")
+
+(define-type t1 (c1 (n number?)))
+(test (c1 'not-a-number) (list 5))

collects/tests/plai/gc/bad-collectors/no-collection-collector.ss

@@ -0,0 +1,18 @@
+#lang plai/collector
+
+(define ptr 0)
+
+(define (init-allocator) (void))
+
+(define (gc:deref loc) #f)
+(define (gc:alloc-flat hv) 0)
+(define (gc:cons hd tl) 0)
+(define (gc:first pr) 0)
+(define (gc:rest pr) 0)
+(define (gc:flat? loc) #t)
+(define (gc:cons? loc) #f)
+(define (gc:set-first! pr new) (void))
+(define (gc:set-rest! pr new) (void))
+
+(with-heap (vector 1 2 3)
+  (test (gc:deref 0) #f))

collects/tests/plai/gc/bad-mutators/mut-1.ss

@@ -0,0 +1,10 @@
+#lang plai/mutator
+(allocator-setup "../bad-collectors/broken-collector.ss" 12)
+
+50
+60
+70
+80
+(define x (cons 1 2))
+
+(set-first! x x)

collects/tests/plai/gc/bad-mutators/mutator0.ss

@@ -0,0 +1 @@
+#lang plai/mutator

collects/tests/plai/gc/bad-mutators/mutator1.ss

@@ -0,0 +1,2 @@
+#lang plai/mutator
+1

collects/tests/plai/gc/bad-mutators/mutator2.ss

@@ -0,0 +1,2 @@
+#lang plai/mutator
+(allocator-setup "../collectors/trivial-collector.ss" "y")

collects/tests/plai/gc/bad-mutators/mutator3.ss

@@ -0,0 +1,2 @@
+#lang plai/mutator
+(allocator-setup a 100)

collects/tests/plai/gc/bad-mutators/mutator5.ss

@@ -0,0 +1,2 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/trivial-collector.ss")

collects/tests/plai/gc/good-collectors/good-collector.ss

@@ -0,0 +1,546 @@
+#lang plai/collector
+; This collector was written by Robby.
+; It is advanced and particular enough, that I do not expect a student would be brazen enough to copy or plagiarize it, so it is public.
+
+(print-only-errors #t)
+
+#|
+
+heap-layout:
+
+ 0 during gc   : left-side of queue
+   non-gc time : free pointer
+ 1 during-gc   : right-side-of-queue
+   non-gc time : out of memory pointer
+ 2 '()
+ 3 #f
+ 4 #t
+ 5 0
+ 6 1
+ 7 2
+ 8 3
+ 9 4
+ 10 .... (n-10/2): space 1.
+ (n-10/2)+1 ... n: space 2.
+
+|#
+
+;; the bounds on the initial half of a heap.
+(define (first-start) 10)
+(define (second-start) 
+  (unless (even? (- (heap-size) (first-start)))
+    (error 'second-start "bad heap size ~s" (heap-size)))
+  (+ (first-start) (/ (- (heap-size) (first-start)) 2)))
+
+(define (init-allocator) 
+  (unless (even? (heap-size))
+    (error 'two-space.ss "must have an even sized heap"))
+  (when (<= (heap-size) 10)
+    (error 'two-space.ss "heap too small"))
+  (for ([i (in-range 0 (heap-size))])
+    (heap-set!
+     i
+     (cond
+       [(= i 0) (first-start)]
+       [(= i 1) (second-start)]
+       [(immediate-loc? i) (immediate-loc->val i)]
+       [(< i (second-start)) 'free]
+       [else 'bad]))))
+
+(define (immediate-loc? i) (< 1 i (first-start)))
+
+(define (immediate-loc->val i)
+  (case i
+    [(2) #f]
+    [(3) #t]
+    [(4) '()]
+    [else (- i 5)]))
+
+(define (immediate-val? v)
+  (or (and (exact-integer? v)
+           (<= 0 v 4))
+      (eq? v #t)
+      (eq? v #f)
+      (eq? v null)))
+
+(define (immediate-val->loc v)
+  (case v
+    [(#f) 2]
+    [(#t) 3]
+    [(()) 4]
+    [else (+ v 5)]))
+
+(test (immediate-loc? 1) #f)
+(test (immediate-loc? 2) #t)
+(test (immediate-loc? 4) #t)
+(test (immediate-loc? 10) #f)
+(test (immediate-loc->val 5) 0)
+(test (immediate-loc->val 4) '())
+(test (immediate-val->loc (immediate-loc->val 2)) 2)
+(test (immediate-val->loc (immediate-loc->val 3)) 3)
+(test (immediate-val->loc (immediate-loc->val 4)) 4)
+(test (immediate-val->loc (immediate-loc->val 5)) 5)
+(test (immediate-val->loc (immediate-loc->val 6)) 6)
+(test (immediate-val->loc (immediate-loc->val 7)) 7)
+(test (immediate-val->loc (immediate-loc->val 8)) 8)
+(test (immediate-val->loc (immediate-loc->val 9)) 9)
+
+(define (mkheap alloc-ptr alloc-stop . args)
+  (unless (and (number? alloc-ptr) (number? alloc-stop))
+    (error 'mkheap "expected numbers for first two args, got ~e and ~e" alloc-ptr alloc-stop))
+  (apply vector (append (list alloc-ptr alloc-stop  #f #t '() 0 1 2 3 4) args)))
+
+(test (let ([v (make-vector 12 'x)])
+        (with-heap v (init-allocator))
+        v)
+      (mkheap 10 11 'free 'bad))
+
+(test (let ([v (make-vector 20 'x)])
+        (with-heap v (init-allocator))
+        v)
+      (mkheap 10 15
+              'free 'free 'free 'free 'free
+              'bad  'bad  'bad  'bad  'bad))
+
+(define (gc:deref loc) 
+  (cond
+    [(immediate-loc? loc)
+     (immediate-loc->val loc)]
+    [(equal? (heap-ref loc) 'flat)
+     (heap-ref (+ loc 1))]
+    [else
+     (error 'gc:deref "attempted to deref a non flat value, loc ~s" loc)]))
+
+(test (with-heap (mkheap 10 20 'flat 14)
+                 (gc:deref 10))
+      14)
+(test (gc:deref 2) #f)
+(test (gc:deref 3) #t)
+
+(define (gc:first pr-ptr) 
+  (if (equal? (heap-ref pr-ptr) 'pair)
+      (heap-ref (+ pr-ptr 1))
+      (error 'first "non pair")))
+
+(test (with-heap (mkheap 10 20 'pair 0 1)
+                 (gc:first 10))
+      0)
+
+(define (gc:rest pr-ptr) 
+  (if (equal? (heap-ref pr-ptr) 'pair)
+      (heap-ref (+ pr-ptr 2))
+      (error 'first "non pair")))
+
+(test (with-heap (mkheap 10 20 'pair 0 1)
+                 (gc:rest 10))
+      1)
+
+(define (gc:flat? loc) 
+  (cond
+    [(< loc (first-start)) #t]
+    [(equal? (heap-ref loc) 'flat) #t]
+    [else #f]))
+
+(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
+                 (gc:flat? 12))
+      #f)
+(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
+                 (gc:flat? 15))
+      #t)
+(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
+                 (gc:flat? 5))
+      #t)
+
+(define (gc:cons? loc) 
+  (cond
+    [(< loc (first-start)) #f]
+    [else
+     (equal? (heap-ref loc) 'pair)]))
+
+(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
+                 (gc:cons? 12))
+      #t)
+(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
+                 (gc:cons? 15))
+      #f)
+(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
+                 (gc:cons? 5))
+      #f)
+
+(define (gc:set-first! pr-ptr new) 
+  (if (equal? (heap-ref pr-ptr) 'pair)
+      (heap-set! (+ pr-ptr 1) new)
+      (error 'set-first! "non pair")))
+
+(test (let ([h (mkheap 10 20 'pair 2 2)])
+        (with-heap h (gc:set-first! 10 3))
+        h)
+      (mkheap 10 20 'pair 3 2))
+
+(define (gc:set-rest! pr-ptr new) 
+  (if (equal? (heap-ref pr-ptr) 'pair)
+      (heap-set! (+ pr-ptr 2) new)
+      (error 'set-first! "non pair")))
+
+(test (let ([h (mkheap 10 20 'pair 2 2)])
+        (with-heap h (gc:set-rest! 10 3))
+        h)
+      (mkheap 10 20 'pair 2 3))
+
+(define (gc:alloc-flat fv)
+  (cond
+    [(immediate-val? fv)
+     (immediate-val->loc fv)]
+    [else
+     (let ([ptr (alloc 2)])
+       (cond
+         [ptr
+          (fill-in-flat ptr fv)]
+         [else
+          (init-gc)
+          (when (procedure? fv)
+            (move-roots (procedure-roots fv)))
+          (collect-garbage)
+          (let ([ptr (alloc 2)])
+            (unless ptr
+              (error 'two-space.ss "out of memory"))
+            (fill-in-flat ptr fv))]))]))
+
+(define (fill-in-flat ptr fv)
+  (heap-set! ptr 'flat)
+  (heap-set! (+ ptr 1) fv)
+  ptr)
+  
+(define (gc:cons hd tl)
+  (let ([ptr (alloc 3)])
+    (cond
+      [ptr
+       (fill-in-cons ptr hd tl)]
+      [else
+       (init-gc)
+       (let ([new-hd (move-loc hd)]
+             [new-tl (move-loc tl)])
+         (collect-garbage)
+         (let ([ptr (alloc 3)])
+           (unless ptr
+             (error 'two-space.ss "out of memory"))
+           (fill-in-cons ptr new-hd new-tl)))])))
+
+(define (fill-in-cons ptr hd tl)
+  (heap-set! ptr 'pair)
+  (heap-set! (+ ptr 1) hd)
+  (heap-set! (+ ptr 2) tl)
+  ptr)
+
+;; alloc : number -> boolean
+;; returns #f if nothing can be allocated
+(define (alloc n)
+  (let ([next (heap-ref 0)])
+    (cond
+      [(<= (+ next n) (heap-ref 1))
+       (heap-set! 0 (+ next n))
+       next]
+      [else
+       #f])))
+
+(test (let ([h (mkheap 16 16
+                       'fwd  17    'flat 112   'pair 10    10
+                       'free 'free 'free 'free 'free 'free 'free)])
+        (with-heap h (alloc 3)))
+      #f)
+
+(test (let ([h (mkheap 10 16
+                       'free 'free 'free 'free 'free 'free 'free
+                       'free 'free 'free 'free 'free 'free 'free)])
+        (with-heap h (alloc 3))
+        h)
+      (mkheap 13 16
+              'free 'free 'free 'free 'free 'free 'free
+              'free 'free 'free 'free 'free 'free 'free))
+
+(define (init-gc)
+  (cond
+    [(< (heap-ref 0) (second-start))
+     (heap-set! 0 (second-start))]
+    [else
+     (heap-set! 0 (first-start))])
+  (heap-set! 1 (heap-ref 0)))
+
+(test (let ([h (mkheap 16 16
+                       'fwd  17    'flat 112   'pair 10    10
+                       'free 'free 'free 'free 'free 'free 'free)])
+        (with-heap h (init-gc))
+        h)
+      (mkheap 17 17
+              'fwd  17    'flat 112   'pair 10    10
+              'free 'free 'free 'free 'free 'free 'free))
+
+(test (let ([h (mkheap 15 16
+                       'fwd  17    'flat 112   'pair 10    10
+                       'free 'free 'free 'free 'free 'free 'free)])
+        (with-heap h (init-gc))
+        h)
+      (mkheap 17 17
+              'fwd  17    'flat 112   'pair 10    10
+              'free 'free 'free 'free 'free 'free 'free))
+
+(define (finalize-gc)
+  (heap-set! 0 (heap-ref 1))
+  (cond
+    [(< (heap-ref 0) (second-start))
+     (heap-set! 1 (second-start))
+     (for ([i (in-range (second-start) (heap-size))])
+       (heap-set! i 'bad))]
+    [else
+     (heap-set! 1 (heap-size))
+     (for ([i (in-range (first-start) (second-start))])
+       (heap-set! i 'bad))])
+  (for ([i (in-range (heap-ref 0) (heap-ref 1))])
+    (heap-set! i 'free)))
+
+(test (let ([h (mkheap 20 20
+                       'flat 17 'flat 12    'free 'free 'free
+                       'pair 12  10   'free 'free 'free 'free)])
+        (with-heap h (finalize-gc))
+        h)
+      (mkheap 20 24
+              'bad  'bad 'bad 'bad  'bad  'bad  'bad
+              'pair 12   10   'free 'free 'free 'free))
+
+(test (let ([h (mkheap 14 14
+                       'flat 17 'flat 12    'free 'free 'free
+                       'pair 12  10   'free 'free 'free 'free)])
+        (with-heap h (finalize-gc))
+        h)
+      (mkheap 14 17
+              'flat 17 'flat 12    'free 'free 'free
+              'bad  'bad 'bad 'bad  'bad  'bad  'bad))
+
+(define (collect-garbage)
+  (move-roots (get-root-set))
+  (copy-data)
+  (finalize-gc))
+  
+;; move-roots : (listof roots) -> void
+(define (move-roots roots)
+  (cond
+    [(null? roots) (void)]
+    [else 
+     (set-root! (car roots) (move-loc (read-root (car roots))))
+     (move-roots (cdr roots))]))
+
+;; move-loc : loc[from-space] -> loc[to-space]
+(define (move-loc loc)
+  (cond
+    [(immediate-loc? loc)
+     loc]
+    [else
+     (case (heap-ref loc)
+       [(fwd) (heap-ref (+ loc 1))]
+       [(pair) 
+        (let ([dest (heap-ref 1)])
+          (heap-set! dest 'pair)
+          (heap-set! (+ dest 1) (heap-ref (+ loc 1)))
+          (heap-set! (+ dest 2) (heap-ref (+ loc 2)))
+          (heap-set! 1 (+ dest 3))
+          (heap-set! loc 'fwd)
+          (heap-set! (+ loc 1) dest)
+          (heap-set! (+ loc 2) 'junk)
+          dest)]
+       [(flat) 
+        (let ([dest (heap-ref 1)])
+          (heap-set! dest 'flat)
+          (heap-set! (+ dest 1) (heap-ref (+ loc 1)))
+          (heap-set! 1 (+ dest 2))
+          (heap-set! loc 'fwd)
+          (heap-set! (+ loc 1) dest)
+          dest)]
+       [else
+        (error 'move-loc "found a non-tag at location ~a" loc)])]))
+
+(test (move-loc 4) 4)
+
+(test (let ([v (mkheap 15 15 
+                       'fwd   17 'free 'free 'free 
+                       'free 'free 'free 'free 'free)])
+        (list (with-heap v (move-loc 10))
+              v))
+      (list 17
+            (mkheap 15 15 
+                    'fwd   17   'free 'free 'free 
+                    'free 'free 'free 'free 'free)))
+
+(test (let ([v (mkheap 15 15 
+                       'flat 13 'free 'free 'free 
+                       'free 'free 'free 'free 'free)])
+        (list (with-heap v (move-loc 10))
+              v))
+      (list 15
+            (mkheap 15 17
+                    'fwd  15 'free 'free 'free
+                    'flat 13 'free 'free 'free)))
+
+(test (let ([v (mkheap 15 15 
+                       'pair 10 10 'free 'free 
+                       'free 'free 'free 'free 'free)])
+        (list (with-heap v (move-loc 10))
+              v))
+      (list 15
+            (mkheap 15 18
+                    'fwd  15 'junk 'free 'free
+                    'pair 10 10 'free 'free)))
+
+(define (copy-data)
+  (let ([left (heap-ref 0)]
+        [right (heap-ref 1)])
+  (when (< left right)
+    (case (heap-ref left)
+      [(pair)
+       (maybe-move/loc left 1)
+       (maybe-move/loc left 2)
+       (heap-set! 0 (+ left 3))]
+      [(flat)
+       (heap-set! 0 (+ left 2))]
+      [(proc)
+       (maybe-move/roots left (procedure-roots (heap-ref (+ left 1))))
+       (heap-set! 0 (+ left 2))]
+      [else
+       (error 'copy-data "unknown tag ~s" (heap-ref left))])
+    (copy-data))))
+
+;; maybe-move/loc : loc[to-space] offset -> void
+;; moves the pointer at record+offset if it is in a different
+;; semispace from record.
+(define (maybe-move/loc record delta)
+  (let ([pointer (heap-ref (+ record delta))])
+    (unless (different-halves? record pointer)
+      (error 'maybe-move/loc "tried to move a pointer that was in the from space already ~s ~s" record pointer))
+    ;; now we know pointer is in the from-space
+    (heap-set! (+ record delta) (move-loc pointer))))
+
+;; maybe-move/roots : loc[to-space] (listof root) -> void
+(define (maybe-move/roots record roots)
+  (cond
+    [(null? roots) (void)]
+    [else 
+     (maybe-move/root record (car roots))
+     (maybe-move/roots record (cdr roots))]))
+
+;; maybe-move/root : loc[to-space] root -> void
+;; moves the pointer in the root if it is in a different
+;; semispace from record.
+(define (maybe-move/root record root)
+  (let ([pointer (read-root root)])
+    (unless (different-halves? record pointer)
+      (error 'maybe-move/root "tried to move a pointer that was in the from space already"))
+    ;; now we know pointer is in the from-space
+    (set-root! root (move-loc pointer))))
+  
+;; different-halves? : loc loc -> boolean
+;; returns #t if n and m are in different halves of the heap.
+(define (different-halves? n m)
+  (cond
+    [(or (immediate-loc? n) 
+         (immediate-loc? m))
+     #f]
+    [else
+     (not (equal? (< n (second-start))
+                  (< m (second-start))))]))
+     
+(test (different-halves? 2 3) #f)
+
+(test (with-heap (mkheap 10 15 
+                         'free 'free 'free 'free 'free
+                         'free 'free 'free 'free 'free)
+                 (different-halves? 12 13))
+      #f)
+(test (with-heap (mkheap 10 15 
+                         'free 'free 'free 'free 'free
+                         'free 'free 'free 'free 'free)
+                 (different-halves? 12 17))
+      #t)
+(test (with-heap (mkheap 10 15 
+                         'free 'free 'free 'free 'free
+                         'free 'free 'free 'free 'free)
+                 (different-halves? 16 17))
+      #f)
+(test (with-heap (mkheap 10 15 
+                         'free 'free 'free 'free 'free
+                         'free 'free 'free 'free 'free)
+                 (different-halves? 17 12))
+      #t)
+
+(test (with-heap (mkheap 17 20
+                         'fwd  17 'junk 'free 'free 'free 'free
+                         'pair 11  11   'free 'free 'free 'free)
+                 (different-halves? 17 11))
+      #t)
+
+(test (let ([h (mkheap 17 22
+                       'fwd  17    'free 'free 'free 'free 'free
+                       'flat 11    'pair  17   10    'free 'free)])
+        (with-heap h (maybe-move/loc 19 2))
+        h)
+      (mkheap 17 22
+              'fwd  17    'free 'free 'free 'free 'free
+              'flat 11    'pair  17   17    'free 'free))
+
+(test (let ([h (mkheap 17 22
+                       'flat 12    'free 'free 'free 'free 'free
+                       'flat 11    'pair  17   10    'free 'free)])
+        (with-heap h (maybe-move/loc 19 2))
+        h)
+      (mkheap 17 24
+              'fwd  22    'free 'free 'free 'free 'free
+              'flat 11    'pair  17    22    'flat '12))
+
+(test (let ([h (mkheap 17 19
+                       'free 'free 'free 'free 'free 'free 'free
+                       'flat 11    'free 'free 'free 'free 'free)])
+        (with-heap h (copy-data))
+        h)
+      (mkheap 19 19
+              'free 'free 'free 'free 'free 'free 'free
+              'flat 11    'free 'free 'free 'free 'free))
+
+(test (let ([h (mkheap 17 20
+                       'fwd  17 'junk 'free 'free 'free 'free
+                       'pair 10  10   'free 'free 'free 'free)])
+        (with-heap h (copy-data))
+        h)
+      (mkheap 20 20
+              'fwd  17 'junk 'free 'free 'free 'free
+              'pair 17  17   'free 'free 'free 'free))
+
+(test (let ([h (mkheap 17 20
+                       'fwd  17 'flat 112   'free 'free 'free
+                       'pair 12  10   'free 'free 'free 'free)])
+        (with-heap h (copy-data))
+        h)
+      (mkheap 22 22
+              'fwd  17 'fwd  20    'free 'free 'free
+              'pair 20  17   'flat 112 'free 'free))
+
+(test (gc:alloc-flat 1)
+      6)
+
+
+(test (let ([h (mkheap 15 17
+                       'flat 17 'pair 10    10    'free 'free
+                       'pair 12  10   'free 'free 'free 'free)])
+        (list (with-heap h (gc:alloc-flat 111))
+              h))
+      (list 15
+            (mkheap 17 17
+                    'flat  17 'pair 10    10   'flat 111
+                    'pair 12  10   'free 'free 'free 'free)))
+
+(test (let ([h (mkheap 14 17
+                       'flat 17 'flat 12    'free 'free 'free
+                       'pair 12  10   'free 'free 'free 'free)])
+        (list (with-heap h (gc:cons 10 10))
+              h))
+      (list 14
+            (mkheap 17 17
+                    'flat 17 'flat 12    'pair 10    10
+                    'pair 12  10   'free 'free 'free 'free)))

collects/tests/plai/gc/good-collectors/trivial-collector.ss

@@ -0,0 +1,54 @@
+#lang plai/collector
+(define heap-ptr 'uninitialized-heap-ptr)
+
+(define (init-allocator)
+  ; calling heap-offset before init-allocator is called gives 'undefined
+ (set! heap-ptr 0))
+
+(define (gc:alloc-flat p)
+  (begin 
+    (when (> (+ heap-ptr 2) (heap-size))
+      (error "out of memory"))
+    (heap-set! heap-ptr 'prim)
+    (heap-set! (+ 1 heap-ptr) p)
+    (set! heap-ptr (+ 2 heap-ptr))
+    ; return the location of this flat data
+    (- heap-ptr 2)))
+
+(define (gc:cons f r)
+  (begin
+    (when (> (+ heap-ptr 3) (heap-size))
+      (error "out of memory"))
+    (heap-set! heap-ptr 'cons)
+    (heap-set! (+ 1 heap-ptr) f)
+    (heap-set! (+ 2 heap-ptr) r)
+    (set! heap-ptr (+ 3 heap-ptr))
+    (- heap-ptr 3)))
+
+(define (gc:deref a)
+  (heap-ref (+ 1 a)))
+
+; number -> boolean
+(define (gc:cons? a)
+  (eq? (heap-ref a) 'cons))
+
+; number -> any
+(define (gc:first a)
+  (heap-ref (+ 1 a)))
+
+; number -> number
+(define (gc:rest a)
+  (heap-ref (+ 2 a)))
+
+(define (gc:set-first! a f)
+  (if (gc:cons? a)
+      (heap-set! (+ 1 a) f)
+      (error 'set-first! "expects address of cons")))
+
+(define (gc:set-rest! a r)
+  (heap-set! (+ 2 a) r))
+
+; function number -> boolean
+(define (gc:flat? a)
+  (eq? 'prim (heap-ref a)))
+

collects/tests/plai/gc/good-mutators/andor.ss

@@ -0,0 +1,8 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 400)
+(define (do-one i) (/ (- i 1)))
+(define (loop i)
+  (or (= 1 i)
+      (and (do-one i)
+           (loop (- i 1)))))
+(loop 50)

collects/tests/plai/gc/good-mutators/app.ss

@@ -0,0 +1,11 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 28)
+
+(define (app f)
+  (lambda (x)
+    (f x)))
+
+(define plus (app add1))
+
+(plus 23)
+(plus 5)

collects/tests/plai/gc/good-mutators/bindings.ss

@@ -0,0 +1,26 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 58)
+
+(define x 'intial)
+(set! x 'final)
+(test/value=? x 'final)
+
+
+(define y
+  (let ([outer-local
+       (let ([inner-local 'value-expected])
+         inner-local)])
+  outer-local))
+
+(test/value=? y 'value-expected)
+
+(define (local-vars)
+  (let ([x 23] [y 23])
+    x))
+
+(test/value=? (local-vars) 23)
+
+(define (locals-2 x)
+  (+ x 5))
+
+(test/value=? (locals-2 23) 28)

collects/tests/plai/gc/good-mutators/by-val.ss

@@ -0,0 +1,13 @@
+; Ensure that call by value is correctly implemented.
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 40)
+
+(define global-val 'global)
+
+(define (mut-arg arg)
+  (set! arg 'mutated))
+
+(mut-arg global-val)
+
+
+(test/value=? global-val 'global)

collects/tests/plai/gc/good-mutators/case.ss

@@ -0,0 +1,8 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 40)
+(test/value=? (case 1 [(1) 2])
+              2)
+(test/value=? (case 1 [(1) 2] [else 3])
+              2)
+(test/value=? (case 2 [(1) 2] [else 3])
+              3)

collects/tests/plai/gc/good-mutators/circular.ss

@@ -0,0 +1,11 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 68)
+
+(define (gen-circular)
+  (let ([x (cons 3 4)])
+    (let ([y (cons 2 x)])
+      (set-rest! x y)
+      x)))
+
+(define x (gen-circular))
+(test/location=? x (rest (rest x)))

collects/tests/plai/gc/good-mutators/classic-error.ss

@@ -0,0 +1,14 @@
+#lang plai/mutator
+; This is `classic' in that caught many bugs in copying collectors that students wrote for CS173, Fall 2007.
+(allocator-setup "../good-collectors/good-collector.ss" 38)
+
+'trash
+'junk
+; after GC, alpha beta are copied but the cons refernces them in the old semispace
+(define my-pair (cons 'alpha 'beta))
+; we have room for our-pair, but 'refuse forces a semi-space swap that exposes
+; the memory corruption (if one exists)
+'refuse
+(define our-pair (cons my-pair my-pair))
+(test/value=? our-pair '((alpha . beta) . (alpha . beta)))
+(test/location=? (first our-pair) (rest our-pair))

collects/tests/plai/gc/good-mutators/closure-1.ss

@@ -0,0 +1,13 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 60)
+
+(define lst '(2 -10)) ; (cons 2 (cons -10 empty)))
+
+(define (map f lst)
+  (if (cons? lst)
+      (cons (f (first lst)) (map f (rest lst)))
+      empty))
+
+(define x 'gc-garbage)
+
+(test/value=? (map add1 lst) '(3 -9))

collects/tests/plai/gc/good-mutators/closure-2.ss

@@ -0,0 +1,16 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 58)
+
+
+(define make-conser
+  (lambda (n)
+    (lambda (x) 
+      (cons n x))))
+
+
+(define kons (make-conser 'catamaran))
+;1 2 3 5 6 7 
+(kons 'people)
+(kons 'maroon)
+(kons 'srfi)
+(test/value=? (kons 'peace) '(catamaran . peace))

collects/tests/plai/gc/good-mutators/else.ss

@@ -0,0 +1,5 @@
+#lang plai/mutator
+; Is else defined?
+(allocator-setup "../good-collectors/good-collector.ss" 40)
+
+(test/value=? (cond [else 28935723]) 28935723)

collects/tests/plai/gc/good-mutators/empty-mutator.ss

@@ -0,0 +1,3 @@
+#lang plai/mutator
+
+(allocator-setup "../good-collectors/good-collector.ss" 80)

collects/tests/plai/gc/good-mutators/gc-order.ss

@@ -0,0 +1,9 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 58)
+
+(define x 3)
+(cons (begin (set! x 2)
+             1)
+      (begin (set! x 3)
+             1))
+(test/value=? x 3)

collects/tests/plai/gc/good-mutators/global-roots.ss

@@ -0,0 +1,11 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 20)
+
+
+(define car first)
+
+
+'junk
+'junk
+'junk
+(test/value=? (car (cons 'this-car 2)) 'this-car)

collects/tests/plai/gc/good-mutators/imports.ss

@@ -0,0 +1,7 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 20)
+
+(import-primitives modulo)
+
+(test/value=? (modulo 5 3) 2)
+

collects/tests/plai/gc/good-mutators/kathi-bug-1.ss

@@ -0,0 +1,4 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 84)
+(define L (cons 3 empty))
+(test/value=? L '(3))

collects/tests/plai/gc/good-mutators/mutator4.ss

@@ -0,0 +1,3 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 100)
+(cons 4 #t)

collects/tests/plai/gc/good-mutators/mutator6.ss

@@ -0,0 +1,5 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 58)
+
+(define x 'intial)
+(test/value=? x 'intial)

collects/tests/plai/gc/good-mutators/mutator7.ss

@@ -0,0 +1,8 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 58)
+
+(define x 'initial)
+
+(eq? x x)
+(eq? x 'initial)
+(eq? 5 4)

collects/tests/plai/gc/good-mutators/names.ss

@@ -0,0 +1,3 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 400)
+(let ([f (λ (x) x)]) f)

collects/tests/plai/gc/good-mutators/proc-list.ss

@@ -0,0 +1,17 @@
+#lang plai/mutator
+; Demonstrates garbage collection while a closure is on the stack.  A correct collector must ensure that the roots
+; reachable from (make-adder 90) and (make-adder 200) -- that is, the values 90 and 200 that k is bound to -- do
+; not get discarded.
+(allocator-setup "../good-collectors/good-collector.ss" 68)
+
+(define (make-adder k)
+  (lambda (n) (+ n k)))
+
+(define proc-list
+  (cons (make-adder 90)
+        (cons (make-adder 200)
+              empty)))
+
+(test/value=? ((first proc-list) 7) 97)
+(test/value=? ((first proc-list) 300) 390)
+(test/value=? ((first (rest proc-list)) 73) 273)

collects/tests/plai/gc/good-mutators/repeat-test.ss

@@ -0,0 +1,14 @@
+#lang plai/mutator
+
+(allocator-setup "../good-collectors/good-collector.ss" 30)
+
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))

collects/tests/plai/gc/good-mutators/student-1.ss

@@ -0,0 +1,131 @@
+#lang plai/mutator
+
+; mark-and-sweep-test.ss - Ben Childs
+; Designed to test the mark and sweep collector
+; Runs three tests:
+;
+; Allocation of subsequently larger lists
+;
+; Use of Local variables in a loop (garbage after each iteration)
+; Followed by allocation of large list (verifies that they are correctly collected)
+;
+; Generation of a number of circularly referenced lists
+; Followed by allocation of several large lists
+;
+; Finally it runs the sample tests distributed with the assignment
+
+
+(allocator-setup "../good-collectors/good-collector.ss" 1000)
+
+; Helper to generate long lists
+(define (gen-list x)
+  (if (zero? x) '() (cons x (gen-list (- x 1)))))
+
+; Function that defines local vars
+(define (local-vars)
+  (let ((x 3) (y 5) (z 10) (a 5))
+    (+ x (- 10 y))))
+
+(define (loop x)
+  
+  (printf "Iteration: ~a~n" x)
+  
+  (if (zero? x) 0
+        (loop (- (+ (local-vars) (- x 1)) 8))))
+; Generate gradually increasing sizes of lists
+; To trigger garbage collection at different points
+(printf "~a~n" (gen-list 1))
+(printf "~a~n" (gen-list 2))
+(printf "~a~n" (gen-list 4))
+(printf "~a~n" (gen-list 8))
+
+; Run a loop that uses local vars a few times
+(printf "Generating Primitives in loops~n")
+(loop 20)
+
+(printf "Try Allocating large list again~n")
+(printf "~a~n" (gen-list 8))
+
+
+; Create some circular references
+(define (gen-circular)
+  (let ([x (cons 3 4)])
+    (let ([y (cons 2 x)])
+      (set-rest! x y)
+      x)))
+
+(printf "Testing Circular References~n")
+(printf "~a~n" (gen-circular))
+(printf "~a~n" (gen-circular))
+(printf "~a~n" (gen-circular))
+(printf "~a~n" (gen-circular))
+(printf "~a~n" (gen-circular))
+(printf "~a~n" (gen-circular))
+(printf "~a~n" (gen-circular))
+(printf "~a~n" (gen-circular))
+(printf "~a~n" (gen-circular))
+
+(printf "Try allocating large list again~n")
+(printf "~a~n" (gen-list 8))
+(printf "~a~n" (gen-list 8))
+(printf "~a~n" (gen-list 8))
+(printf "~a~n" (gen-list 8))
+(printf "~a~n" (gen-list 8))
+
+(printf "Running sample tests~n")
+(define (fact x)
+  (if (zero? x)
+      1
+      (* x (fact (sub1 x)))))
+
+(define (fact-help x a)
+  (if (zero? x)
+      a
+      (fact-help (sub1 x) (* x a))))
+
+(define lst (cons 1 (cons 2 (cons 3 empty))))
+
+(define (map-add n lst)
+  (map (lambda (x) (+ n x)) lst))
+
+(define (map f lst)
+  (if (cons? lst)
+      (cons (f (first lst)) (map f (rest lst)))
+      empty))
+
+(define (filter p lst)
+  (if (cons? lst)
+      (if (p (first lst))
+          (cons (first lst) (filter p (rest lst)))
+          (filter p (rest lst)))
+      lst))
+
+(define (append l1 l2)
+  (if (cons? l1)
+      (cons (first l1) (append (rest l1) l2))
+      l2))
+
+(define (length lst)
+  (if (empty? lst)
+      0
+      (add1 (length (rest lst)))))
+
+(define tail (cons 1 empty))
+(define head (cons 4 (cons 3 (cons 2 tail))))
+(set-rest! tail head)
+
+(printf "res ~a~n" head)
+(set! head empty)
+(set! tail head)
+(printf "res ~a~n" lst)
+(printf "res ~a~n" (length '(hello goodbye)))
+(printf "res ~a~n" (map sub1 lst))
+
+(printf "(fact-help 15 1): ~a~n" (fact-help 15 1))
+(printf "(fact 9): ~a~n" (fact 9))
+
+(printf "(append lst lst): ~a~n" (append lst lst))
+
+(printf "(map-add 5 lst): ~a~n" (map-add 5 lst))
+(printf "(filter even? (map sub1 lst)): ~a~n" (filter even? (map sub1 lst)))
+(printf "(length lst): ~a~n" (length lst))

collects/tests/plai/gc/good-mutators/tail-calls.ss

@@ -0,0 +1,18 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 68)
+
+(define (length-accum lst len)
+  (if (empty? lst)
+      len
+      (length-accum (rest lst) (+ 1 len))))
+
+(define (length lst)
+  (length-accum lst 0))
+
+(define (fact/acc n a)
+  (if (zero? n)
+      a
+      (fact/acc (- n 1) (* n a))))
+
+(test/value=? (length '(1 2 3 4)) 4)
+(test/value=? (fact/acc 40 1) 815915283247897734345611269596115894272000000000)

collects/tests/plai/gc/good-mutators/test-framework.ss

@@ -0,0 +1,5 @@
+#lang plai/mutator
+(allocator-setup "../good-collectors/good-collector.ss" 28)
+
+(halt-on-errors #t)
+(test/value=? 12 12)

collects/tests/plai/gc/run-test.ss

@@ -0,0 +1,20 @@
+#lang scheme
+(require tests/eli-tester
+         scheme/runtime-path)
+
+(define-runtime-path here ".")
+
+(define (in-directory pth rx)
+  (in-list
+   (map (curry build-path pth)
+        (filter (compose (curry regexp-match rx) path->bytes)
+                (directory-list pth)))))
+
+(define (test-mutator m)
+  (parameterize ([current-namespace (make-base-empty-namespace)])
+    (dynamic-require m #f)))
+
+(test
+ (for ([m (in-directory (build-path here "bad-mutators") #rx"ss$")])
+   (test
+    (test-mutator m) =error> #rx"")))

collects/tests/plai/hof-env-buggy.scm

@@ -1,107 +0,0 @@
-(define-type FWAE
-  [num (n number?)]
-  [add (lhs FWAE?) (rhs FWAE?)]
-  [sub (lhs FWAE?) (rhs FWAE?)]
-  [id (name symbol?)]
-  [with (name symbol?) (named-expr FWAE?) (body FWAE?)]
-  [fun (param symbol?) (body FWAE?)]
-  [app (fun-expr FWAE?) (arg-expr FWAE?)])
-
-;; parse : sexp $\longrightarrow$ FWAE
-;; to convert s-expressions into FWAEs
-
-(define (parse sexp)
-  (cond
-   [(symbol? sexp) (id sexp)]
-   [(number? sexp) (num sexp)]
-   [(list? sexp)
-    (case (first sexp)
-      [(+) (add (parse (second sexp))
-                     (parse (third sexp)))]
-      [(-) (sub (parse (second sexp))
-                     (parse (third sexp)))]
-      [(with) (with (first (second sexp))
-                         (parse (second (second sexp)))
-                         (parse (third sexp)))]
-      [(fun) (fun (first (second sexp)) (parse (third sexp)))]
-      [else (app (parse (first sexp)) (parse (second sexp)))])]))
-
-;; num+ : \scheme|num| \scheme|num| -> \scheme|num|
-
-(define (num+ n1 n2)
-  (num (+ (num-n n1) (num-n n2))))
-
-;; num- : \scheme|num| \scheme|num| -> \scheme|num|
-
-(define (num- n1 n2)
-  (num (- (num-n n1) (num-n n2))))
-
-(define-type Subcache
-  [mtSub]
-  [aSub (name symbol?) (value FWAE?) (sc Subcache?)])
-
-;; lookup : symbol \scheme|SubCache| -> \scheme|FWAE|
-
-(define (lookup name sc)
-  (type-case Subcache sc
-             [mtSub () (error 'lookup "no binding for identifier")]
-             [aSub (bound-name bound-value rest-sc)
-                   (if (symbol=? bound-name name)
-                       bound-value
-                       (lookup name rest-sc))]))
-
-;; interp : \scheme|FWAE| \scheme|SubCache| $\rightarrow$ \scheme|FWAE|
-;; evaluates \scheme|FWAE| expressions by reducing them to their corresponding values
-;; return values are either \scheme|num| or \scheme|fun|
-
-(define (interp expr sc)
-  (type-case FWAE expr
-             [num (n) expr]
-             [add (l r) (num+ (interp l sc) (interp r sc))]
-             [sub (l r) (num- (interp l sc) (interp r sc))]
-             [with (bound-id named-expr bound-body)
-                   (interp bound-body
-                           (aSub bound-id
-                                      (interp named-expr sc)
-                                      sc))]
-             [id (v) (lookup v sc)]
-             [fun (bound-id bound-body)
-                  expr]
-             [app (fun-expr arg-expr)
-                  (local ([define fun-val (interp fun-expr sc)])
-                         (interp (fun-body fun-val)
-                                 (aSub (fun-param fun-val)
-                                            (interp arg-expr sc)
-                                            sc)))]))
-
-(define (interp-test expr ans)
-  (test (interp (parse expr) (mtSub)) (num ans)))
-
-(define (interp-test-error expr expected-exception-msg)
-  (test/exn (lambda () (interp (parse expr) (mtSub))) expected-exception-msg))
-
-
-(interp-test 5 5)
-(interp-test '{+ 5 5} 10)
-(interp-test '{with {x {+ 5 5}} {+ x x}} 20)
-(interp-test '{with {x 5} {+ x x}} 10)
-(interp-test '{with {x {+ 5 5}} {with {y {- x 3}} {+ y y}}} 14)
-(interp-test '{with {x 5} {with {y {- x 3}} {+ y y}}} 4)
-(interp-test '{with {x 5} {+ x {with {x 3} 10}}} 15)
-(interp-test '{with {x 5} {+ x {with {x 3} x}}} 8)
-(interp-test '{with {x 5} {+ x {with {y 3} x}}} 10)
-(interp-test '{with {x 5} {with {y x} y}} 5)
-(interp-test '{with {x 5} {with {x x} x}} 5)
-(interp-test '{{fun {x} {+ x 5}} 5} 10)
-(interp-test '{with {double {fun {x} {+ x x}}} {+ {double 5} {double 10}}} 30)
-(interp-test '{{{fun {x} x} {fun {x} {+ x 5}}} 3} 8)
-"expect error: should yield 7, dyn scope yields 9"
-(interp-test '{with {f {with {x 3} {fun {y} {+ x y}}}}
-                    {with {x 5} {f 4}}} 7)
-
-(test/pred (interp (parse '{fun {x} x}) (mtSub)) fun?)
-
-(test/pred (interp (parse '{with {x 3} {fun {y} {+ x y}}}) (mtSub)) fun?)
-
-(interp-test-error '{with {x x} x} "no binding")
-

collects/tests/plai/hof-env.scm

@@ -1 +0,0 @@
-;; see ../repn-meta/env-proc-rep.scm

collects/tests/plai/hof-subst.scm

@@ -1,140 +0,0 @@
-(define-type FWAE
-  [num (n number?)]
-  [add (lhs FWAE?) (rhs FWAE?)]
-  [sub (lhs FWAE?) (rhs FWAE?)]
-  [id (name symbol?)]
-  [with (name symbol?) (named-expr FWAE?) (body FWAE?)]
-  [fun (param symbol?) (body FWAE?)]
-  [app (fun-expr FWAE?) (arg-expr FWAE?)])
-
-;; parse : sexp $\longrightarrow$ FWAE
-;; to convert s-expressions into FWAEs
-
-(define (parse sexp)
-  (cond
-   [(symbol? sexp) (id sexp)]
-   [(number? sexp) (num sexp)]
-   [(list? sexp)
-    (case (first sexp)
-      [(+) (add (parse (second sexp))
-                     (parse (third sexp)))]
-      [(-) (sub (parse (second sexp))
-                     (parse (third sexp)))]
-      [(with) (with (first (second sexp))
-                         (parse (second (second sexp)))
-                         (parse (third sexp)))]
-      [(fun) (fun (first (second sexp)) (parse (third sexp)))]
-      [else (app (parse (first sexp)) (parse (second sexp)))])]))
-
-;; subst : \scheme|FWAE| symbol \scheme|FWAE| $\rightarrow$ \scheme|FWAE|
-;; substitutes second argument with third argument in first argument,
-;; as per the rules of substitution; the resulting expression contains
-;; no free instances of the second argument
-
-(define (subst expr sub-id val)
-  (type-case FWAE expr
-             [num (n) expr]
-             [add (l r) (add (subst l sub-id val)
-                                  (subst r sub-id val))]
-             [sub (l r) (sub (subst l sub-id val)
-                                  (subst r sub-id val))]
-             [id (v) (if (symbol=? v sub-id) val expr)]
-             [with (bound-id named-expr bound-body)
-                   (if (symbol=? bound-id sub-id)
-                       (with bound-id
-                                  (subst named-expr sub-id val)
-                                  bound-body)
-                       (with bound-id
-                                  (subst named-expr sub-id val)
-                                  (subst bound-body sub-id val)))]
-             [fun (bound-id bound-body)
-                  (if (symbol=? bound-id sub-id)
-                      expr
-                      (fun bound-id
-                                (subst bound-body sub-id val)))]
-             [app (fun-expr arg-expr)
-                  (app (subst fun-expr sub-id val)
-                            (subst arg-expr sub-id val))]))
-
-
-(test (subst (add (id 'x) (id 'x)) 'x (num 5))
-      (add (num 5) (num 5)))
-
-(test (subst (with 'x (num 5) (add (id 'x) (id 'x))) 'x (num 3))
-      (with 'x (num 5) (add (id 'x) (id 'x))))
-
-(test (subst (add (id 'x) (with 'x (num 3) (num 10))) 'x (num 5))
-      (add (num 5) (with 'x (num 3) (num 10))))
-
-(test (subst (add (id 'x) (with 'x (num 3) (id 'x))) 'x (num 5))
-      (add (num 5) (with 'x (num 3) (id 'x))))
-
-(test (subst (parse '{fun {x} {+ x y}}) 'x (num 5))
-      (parse '{fun {x} {+ x y}}))
-
-(test (subst (parse '{fun {x} {+ x y}}) 'y (num 5))
-      (parse '{fun {x} {+ x 5}}))
-
-(test (subst (parse '{{fun {x} {+ x y}} {fun {y} {+ x y}}}) 'y (num 3))
-      (parse '{{fun {x} {+ x 3}} {fun {y} {+ x y}}}))
-
-
-;; num+ : \scheme|num| \scheme|num| -> \scheme|num|
-
-(define (num+ n1 n2)
-  (num (+ (num-n n1) (num-n n2))))
-
-;; num- : \scheme|num| \scheme|num| -> \scheme|num|
-
-(define (num- n1 n2)
-  (num (- (num-n n1) (num-n n2))))
-
-;; interp : \scheme|FWAE| $\rightarrow$ \scheme|FWAE|
-;; evaluates \scheme|FWAE| expressions by reducing them to their corresponding values
-;; return values are either \scheme|num| or \scheme|fun|
-
-(define (interp expr)
-  (type-case FWAE expr
-             [num (n) expr]
-             [add (l r) (num+ (interp l) (interp r))]
-             [sub (l r) (num- (interp l) (interp r))]
-             [with (bound-id named-expr bound-body)
-                   (interp (subst bound-body
-                                  bound-id
-                                  (interp named-expr)))]
-             [id (v) (error 'interp "free identifier")]
-             [fun (bound-id bound-body)
-                  expr]
-             [app (fun-expr arg-expr)
-                  (local ([define fun-val (interp fun-expr)])
-                         (interp (subst (fun-body fun-val)
-                                        (fun-param fun-val)
-                                        (interp arg-expr))))]))
-
-(define (interp-test expr ans)
-  (test (interp (parse expr)) (num ans)))
-
-(define (interp-test-error expr expected-exception-msg)
-  (test/exn (lambda () (interp (parse expr))) expected-exception-msg))
-
-(interp-test '5 5)
-(interp-test '{+ 5 5} 10)
-(interp-test '{with {x {+ 5 5}} {+ x x}} 20)
-(interp-test '{with {x 5} {+ x x}} 10)
-(interp-test '{with {x {+ 5 5}} {with {y {- x 3}} {+ y y}}} 14)
-(interp-test '{with {x 5} {with {y {- x 3}} {+ y y}}} 4)
-(interp-test '{with {x 5} {+ x {with {x 3} 10}}} 15)
-(interp-test '{with {x 5} {+ x {with {x 3} x}}} 8)
-(interp-test '{with {x 5} {+ x {with {y 3} x}}} 10)
-(interp-test '{with {x 5} {with {y x} y}} 5)
-(interp-test '{with {x 5} {with {x x} x}} 5)
-(interp-test '{{fun {x} {+ x 5}} 5} 10)
-(interp-test '{with {double {fun {x} {+ x x}}} {+ {double 5} {double 10}}} 30)
-(interp-test '{{{fun {x} x} {fun {x} {+ x 5}}} 3} 8)
-(interp-test '{with {f {with {x 3} {fun {y} {+ x y}}}}
-                    {with {x 5} {f 4}}} 7)
-
-(test/pred (interp (parse '{fun {x} x})) fun?)
-(test/pred (interp (parse '{with {x 3} {fun {y} {+ x y}}})) fun?)
-
-(test/exn (lambda () (interp (parse '{with {x x} x}))) "free identifier")

collects/tests/plai/subst.scm

@@ -1,82 +0,0 @@
-(define-type WAE
-  [num (n number?)]
-  [add (lhs WAE?) (rhs WAE?)]
-  [sub (lhs WAE?) (rhs WAE?)]
-  [id (name symbol?)]
-  [with (name symbol?) (named-expr WAE?) (body WAE?)])
-
-;; parse : sexp $\longrightarrow$ AE
-;; to convert s-expressions into AEs
-
-(define (parse sexp)
-  (cond
-   [(symbol? sexp) (id sexp)]
-   [(number? sexp) (num sexp)]
-   [(list? sexp)
-    (case (first sexp)
-      [(+) (add (parse (second sexp))
-                     (parse (third sexp)))]
-      [(-) (sub (parse (second sexp))
-                     (parse (third sexp)))]
-      [(with) (with (first (second sexp))
-                         (parse (second (second sexp)))
-                         (parse (third sexp)))])]))
-
-;; subst : \scheme|WAE| symbol \scheme|WAE| $\rightarrow$ \scheme|WAE|
-;; substitutes second argument with third argument in first argument,
-;; as per the rules of substitution; the resulting expression contains
-;; no free instances of the second argument
-
-(define (subst expr sub-id val)
-  (type-case WAE expr
-             [num (n) expr]
-             [add (l r) (add (subst l sub-id val)
-                                  (subst r sub-id val))]
-             [sub (l r) (sub (subst l sub-id val)
-                                  (subst r sub-id val))]
-             [id (v) (if (symbol=? v sub-id) val expr)]
-             [with (bound-id named-expr bound-body)
-                   (if (symbol=? bound-id sub-id)
-                       (with bound-id
-                                  (subst named-expr sub-id val)
-                                  bound-body)
-                       (with bound-id
-                                  (subst named-expr sub-id val)
-                                  (subst bound-body sub-id val)))]))
-
-
-(test (subst (add (id 'x) (id 'x)) 'x (num 5))
-      (add (num 5) (num 5)))
-
-(test (subst (with 'x (num 5) (add (id 'x) (id 'x))) 'x (num 3))
-      (with 'x (num 5) (add (id 'x) (id 'x))))
-
-(test (subst (add (id 'x) (with 'x (num 3) (num 10))) 'x (num 5))
-      (add (num 5) (with 'x (num 3) (num 10))))
-
-(test (subst (add (id 'x) (with 'x (num 3) (id 'x))) 'x (num 5))
-      (add (num 5) (with 'x (num 3) (id 'x))))
-
-(define (calc expr)
-  (type-case WAE expr
-             [num (n) n]
-             [add (l r) (+ (calc l) (calc r))]
-             [sub (l r) (- (calc l) (calc r))]
-             [with (bound-id named-expr bound-body)
-                   (calc (subst bound-body
-                                bound-id
-                                (num (calc named-expr))))]
-             [id (v) (error 'calc "free identifier")]))
-
-(test (calc (parse '5)) 5)
-(test (calc (parse '{+ 5 5})) 10)
-(test (calc (parse '{with {x {+ 5 5}} {+ x x}})) 20)
-(test (calc (parse '{with {x 5} {+ x x}})) 10)
-(test (calc (parse '{with {x {+ 5 5}} {with {y {- x 3}} {+ y y}}})) 14)
-(test (calc (parse '{with {x 5} {with {y {- x 3}} {+ y y}}})) 4)
-(test (calc (parse '{with {x 5} {+ x {with {x 3} 10}}})) 15)
-(test (calc (parse '{with {x 5} {+ x {with {x 3} x}}})) 8)
-(test (calc (parse '{with {x 5} {+ x {with {y 3} x}}})) 10)
-(test (calc (parse '{with {x 5} {with {y x} y}})) 5)
-(test (calc (parse '{with {x 5} {with {x x} x}})) 5)
-(test/exn (lambda () (calc (parse '{with {x x} x}))) "free identifier")

collects/tests/plai/test-harness.ss

@@ -0,0 +1,44 @@
+#lang plai
+
+(define-type WAE
+  [num (n number?)]
+  [id (s symbol?)])
+
+(define (go)
+  (test (num 5) (id 'x))
+  
+  (test 1 (+ 1 0))
+  (test 1 1)
+  (test 1 2)
+  (test (/ 1 0) 0)
+  (test (error "zamboni") 347)
+  
+  (test 3.4 3.4000001)
+  (test +inf.0 +inf.0)
+  
+  (test/pred 0 zero?)
+  (test/pred 1 zero?)
+  (test/pred 1 (error 'pred))
+  (test/pred 1 (lambda (n) (/ 1 0)))
+  (test/pred "a" string->number)
+  
+  (test/exn (error "zamboni") "zamboni")
+  (test/exn (error "samboni") "zamboni")
+  (test/exn 5  "zamboni")
+  (test/exn (/ 1 0) "division")
+  
+  (test/regexp (error "zamboni") "zam")
+  (test/regexp (error "samboni") "zam")
+  (test/regexp 5  "zam")
+  (test/regexp (/ 1 0) "divis")
+  )
+
+(for ([catch? (in-list (list #t #f))])
+  (plai-catch-test-exn catch?)
+  (for ([errors? (in-list (list #t #f))])
+    (print-only-errors errors?)
+    (for ([abridged? (in-list (list #t #f))])
+      (abridged-test-output abridged?)
+      (with-handlers ([exn? (lambda (x) (printf "~S~n" x))])
+        (go))
+      (newline))))

collects/tests/plai/test-random-mutator.ss

@@ -0,0 +1,68 @@
+#lang scheme/base
+(require schemeunit
+         plai/random-mutator)
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "#lang plai/mutator\n'x"))
+ (list 'x))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "#lang plai/collector\ntrue"))
+ (list #t))
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "#lang plai/collector\n1"))
+ (list 1))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "#lang plai/collector\n'(x y 1)"))
+ (list 1 'x 'y))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "#lang plai/collector\n(error 'x \"hm\")(test 'y 'z) (test/exn 'w 'q)"))
+ (list))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "#lang scheme/base\n(error 'x \"hm\")(test 'y 'z) (test/exn 'w 'q)"))
+ (list 'q 'w 'x 'y 'z))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "((error 'x \"hm\")(test 'y 'z) (test/exn 'w 'q))"))
+ (list 'q 'w 'x 'y 'z))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "(true false null)"))
+ (list #f #t'()))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "empty"))
+ (list '()))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "`x"))
+ (list 'x))
+
+(check-equal?
+ (find-heap-values
+  (open-input-string
+   "`(())"))
+ (list '()))

collects/tests/plai/test.ss

@@ -1,30 +0,0 @@
-
-(define (run-one-test lang src mod-only?)
-  (printf "Trying ~a ~a\n" lang src)
-  (let ([prog (with-input-from-file src
-		(lambda ()
-		  (let loop ()
-		    (let ([v (read)])
-		      (if (eof-object? v)
-			  null
-			  (cons v (loop)))))))])
-    (parameterize ([current-namespace (make-namespace)])
-      (eval `(module m (lib ,lang "plai")
-	       ,@prog))
-      (eval `(require m)))
-    (unless mod-only?
-      (let ([n (current-namespace)])
-	(parameterize ([current-namespace (make-namespace 'empty)])
-	  (namespace-attach-module n 'mzscheme)
-	  (namespace-require `(lib ,lang "plai"))
-	  (for-each (lambda (v) (printf "~e\n" (eval v))) prog))))))
-
-(run-one-test "plai-beginner.ss" "arith-interp.scm" #t)
-(run-one-test "plai-intermediate.ss" "arith-interp.scm" #f)
-(for-each (lambda (src)
-	    (run-one-test "plai-advanced.ss" src #f))
-	  '("all.scm"
-	    "arith-interp.scm"
-	    "hof-env-buggy.scm"
-	    "hof-subst.scm"
-	    "subst.scm"))

collects/tests/plai/web.ss

@@ -0,0 +1,7 @@
+#lang plai/web
+
+(define-type A
+  [mta])
+
+(define (start req)
+  "Hello")