diff --git a/collects/plai/CHANGELOG b/collects/plai/CHANGELOG new file mode 100644 index 0000000000..5049f99487 --- /dev/null +++ b/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 ) + + where 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"). diff --git a/collects/plai/collector.ss b/collects/plai/collector.ss new file mode 100644 index 0000000000..c95e964f42 --- /dev/null +++ b/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 ... + + ))])) \ No newline at end of file diff --git a/collects/plai/collector/lang/reader.ss b/collects/plai/collector/lang/reader.ss new file mode 100644 index 0000000000..f170a4281d --- /dev/null +++ b/collects/plai/collector/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + #:language `plai/collector) diff --git a/collects/plai/datatype.ss b/collects/plai/datatype.ss new file mode 100644 index 0000000000..292489b27f --- /dev/null +++ b/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)])) + + + diff --git a/collects/plai/info.ss b/collects/plai/info.ss new file mode 100644 index 0000000000..ccfb54820c --- /dev/null +++ b/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/")) diff --git a/collects/plai/lang/reader.ss b/collects/plai/lang/reader.ss new file mode 100644 index 0000000000..f8b85a8e48 --- /dev/null +++ b/collects/plai/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + #:language `plai) diff --git a/collects/plai/main.ss b/collects/plai/main.ss new file mode 100644 index 0000000000..13a8d32a29 --- /dev/null +++ b/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 ...)])) diff --git a/collects/plai/mutator.ss b/collects/plai/mutator.ss new file mode 100644 index 0000000000..fe8d05668f --- /dev/null +++ b/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 "#"))]) + (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 )" + stx)]))) + +(define-for-syntax allocator-setup-error-msg + "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup )") + +(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 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 , " + "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 or 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))))])) \ No newline at end of file diff --git a/collects/plai/mutator/lang/reader.ss b/collects/plai/mutator/lang/reader.ss new file mode 100644 index 0000000000..370ea7039c --- /dev/null +++ b/collects/plai/mutator/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + #:language `plai/mutator) diff --git a/collects/plai/plai-large.gif b/collects/plai/plai-large.gif new file mode 100644 index 0000000000..42860240e2 Binary files /dev/null and b/collects/plai/plai-large.gif differ diff --git a/collects/plai/plai-small.gif b/collects/plai/plai-small.gif new file mode 100644 index 0000000000..13f1afde15 Binary files /dev/null and b/collects/plai/plai-small.gif differ diff --git a/collects/plai/plai-tool.ss b/collects/plai/plai-tool.ss new file mode 100644 index 0000000000..f273d0e641 --- /dev/null +++ b/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!))) + )) diff --git a/collects/plai/private/collector-exports.ss b/collects/plai/private/collector-exports.ss new file mode 100644 index 0000000000..9457195e7a --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/collects/plai/private/command-line.ss b/collects/plai/private/command-line.ss new file mode 100644 index 0000000000..e1834f0e51 --- /dev/null +++ b/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)) diff --git a/collects/plai/private/gc-core.ss b/collects/plai/private/gc-core.ss new file mode 100644 index 0000000000..e979d4df68 --- /dev/null +++ b/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-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) \ No newline at end of file diff --git a/collects/plai/private/gc-gui.ss b/collects/plai/private/gc-gui.ss new file mode 100644 index 0000000000..7fc819cc38 --- /dev/null +++ b/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)) + "#")] + [(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))) diff --git a/collects/plai/private/gc-transformer.ss b/collects/plai/private/gc-transformer.ss new file mode 100644 index 0000000000..de81c968ee --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/collects/plai/private/sandbox.ss b/collects/plai/private/sandbox.ss new file mode 100644 index 0000000000..539f4e6c89 --- /dev/null +++ b/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)))) + diff --git a/collects/plai/private/test.ss b/collects/plai/private/test.ss new file mode 100644 index 0000000000..e8eb9ad396 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/collects/plai/private/tool-private.ss b/collects/plai/private/tool-private.ss new file mode 100644 index 0000000000..84b530ff94 --- /dev/null +++ b/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])))) diff --git a/collects/plai/random-mutator.ss b/collects/plai/random-mutator.ss new file mode 100644 index 0000000000..d1dc994fe6 --- /dev/null +++ b/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 ) +;; - (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))))) + diff --git a/collects/plai/scribblings/fake-collector.ss b/collects/plai/scribblings/fake-collector.ss new file mode 100644 index 0000000000..b38066d0dd --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/plai/scribblings/fake-mutator.ss b/collects/plai/scribblings/fake-mutator.ss new file mode 100644 index 0000000000..4a403230c9 --- /dev/null +++ b/collects/plai/scribblings/fake-mutator.ss @@ -0,0 +1,3 @@ +#lang scheme +(provide (all-defined-out)) +(define-syntax allocator-setup #f) \ No newline at end of file diff --git a/collects/plai/scribblings/fake-web.ss b/collects/plai/scribblings/fake-web.ss new file mode 100644 index 0000000000..3a356bcbd3 --- /dev/null +++ b/collects/plai/scribblings/fake-web.ss @@ -0,0 +1,3 @@ +#lang scheme +(provide (all-defined-out)) +(define start #f) \ No newline at end of file diff --git a/collects/plai/scribblings/plai.scrbl b/collects/plai/scribblings/plai.scrbl new file mode 100644 index 0000000000..aa00ad5d89 --- /dev/null +++ b/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 location)} + +If evaluating @scheme[_expected-expr] signals an error, the test prints + +@schemeresultfont{(pred-exception result-expr exception-message 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 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. +} diff --git a/collects/plai/test-harness.ss b/collects/plai/test-harness.ss new file mode 100644 index 0000000000..8706ab5952 --- /dev/null +++ b/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) + ' + 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) + ' + 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) \ No newline at end of file diff --git a/collects/plai/web.ss b/collects/plai/web.ss new file mode 100644 index 0000000000..57af60dacb --- /dev/null +++ b/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])) + diff --git a/collects/plai/web/lang/reader.ss b/collects/plai/web/lang/reader.ss new file mode 100644 index 0000000000..f35caf1570 --- /dev/null +++ b/collects/plai/web/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + #:language `plai/web) diff --git a/collects/tests/plai/all.scm b/collects/tests/plai/all.scm deleted file mode 100644 index 4cf4c1af05..0000000000 --- a/collects/tests/plai/all.scm +++ /dev/null @@ -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) - diff --git a/collects/tests/plai/arith-interp.scm b/collects/tests/plai/arith-interp.scm deleted file mode 100644 index fc0b013890..0000000000 --- a/collects/tests/plai/arith-interp.scm +++ /dev/null @@ -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) - diff --git a/collects/tests/plai/datatype-test.ss b/collects/tests/plai/datatype-test.ss deleted file mode 100644 index 904b89b0f4..0000000000 --- a/collects/tests/plai/datatype-test.ss +++ /dev/null @@ -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") - ) diff --git a/collects/tests/plai/datatype.ss b/collects/tests/plai/datatype.ss new file mode 100644 index 0000000000..4098707b16 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/collects/tests/plai/gc/bad-collectors/no-collection-collector.ss b/collects/tests/plai/gc/bad-collectors/no-collection-collector.ss new file mode 100644 index 0000000000..315a98e45a --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/collects/tests/plai/gc/bad-mutators/mut-1.ss b/collects/tests/plai/gc/bad-mutators/mut-1.ss new file mode 100755 index 0000000000..da79121937 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/bad-mutators/mutator0.ss b/collects/tests/plai/gc/bad-mutators/mutator0.ss new file mode 100644 index 0000000000..28b29097e3 --- /dev/null +++ b/collects/tests/plai/gc/bad-mutators/mutator0.ss @@ -0,0 +1 @@ +#lang plai/mutator \ No newline at end of file diff --git a/collects/tests/plai/gc/bad-mutators/mutator1.ss b/collects/tests/plai/gc/bad-mutators/mutator1.ss new file mode 100644 index 0000000000..f11a2fb52c --- /dev/null +++ b/collects/tests/plai/gc/bad-mutators/mutator1.ss @@ -0,0 +1,2 @@ +#lang plai/mutator +1 \ No newline at end of file diff --git a/collects/tests/plai/gc/bad-mutators/mutator2.ss b/collects/tests/plai/gc/bad-mutators/mutator2.ss new file mode 100644 index 0000000000..8538fbff6e --- /dev/null +++ b/collects/tests/plai/gc/bad-mutators/mutator2.ss @@ -0,0 +1,2 @@ +#lang plai/mutator +(allocator-setup "../collectors/trivial-collector.ss" "y") \ No newline at end of file diff --git a/collects/tests/plai/gc/bad-mutators/mutator3.ss b/collects/tests/plai/gc/bad-mutators/mutator3.ss new file mode 100644 index 0000000000..f689e01e7d --- /dev/null +++ b/collects/tests/plai/gc/bad-mutators/mutator3.ss @@ -0,0 +1,2 @@ +#lang plai/mutator +(allocator-setup a 100) \ No newline at end of file diff --git a/collects/tests/plai/gc/bad-mutators/mutator5.ss b/collects/tests/plai/gc/bad-mutators/mutator5.ss new file mode 100644 index 0000000000..675e57a30a --- /dev/null +++ b/collects/tests/plai/gc/bad-mutators/mutator5.ss @@ -0,0 +1,2 @@ +#lang plai/mutator +(allocator-setup "../good-collectors/trivial-collector.ss") \ No newline at end of file diff --git a/collects/tests/plai/gc/good-collectors/good-collector.ss b/collects/tests/plai/gc/good-collectors/good-collector.ss new file mode 100644 index 0000000000..864d3811ac --- /dev/null +++ b/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))) diff --git a/collects/tests/plai/gc/good-collectors/trivial-collector.ss b/collects/tests/plai/gc/good-collectors/trivial-collector.ss new file mode 100755 index 0000000000..b3e1773c85 --- /dev/null +++ b/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))) + diff --git a/collects/tests/plai/gc/good-mutators/andor.ss b/collects/tests/plai/gc/good-mutators/andor.ss new file mode 100644 index 0000000000..3fddd3fc74 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/app.ss b/collects/tests/plai/gc/good-mutators/app.ss new file mode 100755 index 0000000000..0ec5037ae5 --- /dev/null +++ b/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) diff --git a/collects/tests/plai/gc/good-mutators/bindings.ss b/collects/tests/plai/gc/good-mutators/bindings.ss new file mode 100755 index 0000000000..d65e1094a1 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/by-val.ss b/collects/tests/plai/gc/good-mutators/by-val.ss new file mode 100755 index 0000000000..10fd5ab0cf --- /dev/null +++ b/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) diff --git a/collects/tests/plai/gc/good-mutators/case.ss b/collects/tests/plai/gc/good-mutators/case.ss new file mode 100644 index 0000000000..c57daae346 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/circular.ss b/collects/tests/plai/gc/good-mutators/circular.ss new file mode 100755 index 0000000000..7e7d34cb8a --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/classic-error.ss b/collects/tests/plai/gc/good-mutators/classic-error.ss new file mode 100755 index 0000000000..2917d76382 --- /dev/null +++ b/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)) diff --git a/collects/tests/plai/gc/good-mutators/closure-1.ss b/collects/tests/plai/gc/good-mutators/closure-1.ss new file mode 100755 index 0000000000..24249f6335 --- /dev/null +++ b/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)) diff --git a/collects/tests/plai/gc/good-mutators/closure-2.ss b/collects/tests/plai/gc/good-mutators/closure-2.ss new file mode 100755 index 0000000000..a28527827e --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/else.ss b/collects/tests/plai/gc/good-mutators/else.ss new file mode 100755 index 0000000000..ff9ae734e5 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/empty-mutator.ss b/collects/tests/plai/gc/good-mutators/empty-mutator.ss new file mode 100755 index 0000000000..eab5348cbc --- /dev/null +++ b/collects/tests/plai/gc/good-mutators/empty-mutator.ss @@ -0,0 +1,3 @@ +#lang plai/mutator + +(allocator-setup "../good-collectors/good-collector.ss" 80) diff --git a/collects/tests/plai/gc/good-mutators/gc-order.ss b/collects/tests/plai/gc/good-mutators/gc-order.ss new file mode 100644 index 0000000000..bd93fa997d --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/global-roots.ss b/collects/tests/plai/gc/good-mutators/global-roots.ss new file mode 100755 index 0000000000..9a832bd058 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/imports.ss b/collects/tests/plai/gc/good-mutators/imports.ss new file mode 100755 index 0000000000..173c91c9af --- /dev/null +++ b/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) + diff --git a/collects/tests/plai/gc/good-mutators/kathi-bug-1.ss b/collects/tests/plai/gc/good-mutators/kathi-bug-1.ss new file mode 100755 index 0000000000..a00c827de2 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/mutator4.ss b/collects/tests/plai/gc/good-mutators/mutator4.ss new file mode 100644 index 0000000000..b642b4693b --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/mutator6.ss b/collects/tests/plai/gc/good-mutators/mutator6.ss new file mode 100644 index 0000000000..0ddb3ded5b --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/mutator7.ss b/collects/tests/plai/gc/good-mutators/mutator7.ss new file mode 100644 index 0000000000..4018727d23 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/names.ss b/collects/tests/plai/gc/good-mutators/names.ss new file mode 100644 index 0000000000..e2aa03b838 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/proc-list.ss b/collects/tests/plai/gc/good-mutators/proc-list.ss new file mode 100755 index 0000000000..f24367568f --- /dev/null +++ b/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) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/repeat-test.ss b/collects/tests/plai/gc/good-mutators/repeat-test.ss new file mode 100755 index 0000000000..0ecade0cf3 --- /dev/null +++ b/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)) diff --git a/collects/tests/plai/gc/good-mutators/student-1.ss b/collects/tests/plai/gc/good-mutators/student-1.ss new file mode 100755 index 0000000000..db02017fd7 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/collects/tests/plai/gc/good-mutators/tail-calls.ss b/collects/tests/plai/gc/good-mutators/tail-calls.ss new file mode 100755 index 0000000000..7b78f23b0e --- /dev/null +++ b/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) diff --git a/collects/tests/plai/gc/good-mutators/test-framework.ss b/collects/tests/plai/gc/good-mutators/test-framework.ss new file mode 100755 index 0000000000..799993241d --- /dev/null +++ b/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) diff --git a/collects/tests/plai/gc/run-test.ss b/collects/tests/plai/gc/run-test.ss new file mode 100644 index 0000000000..5a09041d32 --- /dev/null +++ b/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""))) \ No newline at end of file diff --git a/collects/tests/plai/hof-env-buggy.scm b/collects/tests/plai/hof-env-buggy.scm deleted file mode 100644 index 320f180c52..0000000000 --- a/collects/tests/plai/hof-env-buggy.scm +++ /dev/null @@ -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") - diff --git a/collects/tests/plai/hof-env.scm b/collects/tests/plai/hof-env.scm deleted file mode 100644 index 2ca543cb27..0000000000 --- a/collects/tests/plai/hof-env.scm +++ /dev/null @@ -1 +0,0 @@ -;; see ../repn-meta/env-proc-rep.scm diff --git a/collects/tests/plai/hof-subst.scm b/collects/tests/plai/hof-subst.scm deleted file mode 100644 index 999faa7f2f..0000000000 --- a/collects/tests/plai/hof-subst.scm +++ /dev/null @@ -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") diff --git a/collects/tests/plai/subst.scm b/collects/tests/plai/subst.scm deleted file mode 100644 index 2921892207..0000000000 --- a/collects/tests/plai/subst.scm +++ /dev/null @@ -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") diff --git a/collects/tests/plai/test-harness.ss b/collects/tests/plai/test-harness.ss new file mode 100644 index 0000000000..7d8ca68766 --- /dev/null +++ b/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)))) \ No newline at end of file diff --git a/collects/tests/plai/test-random-mutator.ss b/collects/tests/plai/test-random-mutator.ss new file mode 100644 index 0000000000..cceb90f224 --- /dev/null +++ b/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 '())) diff --git a/collects/tests/plai/test.ss b/collects/tests/plai/test.ss deleted file mode 100644 index 675d56f098..0000000000 --- a/collects/tests/plai/test.ss +++ /dev/null @@ -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")) diff --git a/collects/tests/plai/web.ss b/collects/tests/plai/web.ss new file mode 100644 index 0000000000..5fa0d7508c --- /dev/null +++ b/collects/tests/plai/web.ss @@ -0,0 +1,7 @@ +#lang plai/web + +(define-type A + [mta]) + +(define (start req) + "Hello") \ No newline at end of file