From e73ac487f966ca76e1ba3b2a8b2c8404285d9c81 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 3 Jan 2009 08:50:13 +0000 Subject: [PATCH 01/49] Welcome to a new PLT day. svn: r12983 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 801092bb94..8803daa287 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "2jan2009") +#lang scheme/base (provide stamp) (define stamp "3jan2009") From e54ad05bb0979d2b3a936875a5b55aa5587cb051 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Jan 2009 12:20:48 +0000 Subject: [PATCH 02/49] doc read/write closed ports => exn:fail svn: r12984 --- collects/scribblings/reference/ports.scrbl | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/collects/scribblings/reference/ports.scrbl b/collects/scribblings/reference/ports.scrbl index 2073b58320..fcf8803761 100644 --- a/collects/scribblings/reference/ports.scrbl +++ b/collects/scribblings/reference/ports.scrbl @@ -7,6 +7,13 @@ a character-based operation, the port's bytes are decoded; see @secref["encodings"]. +When a port corresponds to a file, network connection, or some other +system resource, is must be explicitly closed via +@scheme[close-input-port] or @scheme[close-output-port] (or indirectly +via @scheme[custodian-shutdown-all]) to release low-level resources +associated with the port. For any kind of port, after it is closed, +attempting to read from or write to the port raises @scheme[exn:fail]. + The global variable @scheme[eof] is bound to the end-of-file value, and @scheme[eof-object?] returns @scheme[#t] only when applied to this value. Reading from a port produces an end-of-file result when the From ca58e72aa0bf16e01b83d0398ada18d5132f0521 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Jan 2009 16:37:42 +0000 Subject: [PATCH 03/49] added note about contracts & tail rec svn: r12985 --- doc/release-notes/mzscheme/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 51cfe16b99..ebfcfd7801 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,7 @@ +Somewhere in there: + function contracts now preserve tail recursion in many cases; the + 'any' contract is no longer special. + Version 4.1.3.8 Added procedure-rename Added extra arguments to call-with-continuation-prompt From 3af2ea45d0fee37c955f9108bc872cba8929d7b8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Jan 2009 16:40:54 +0000 Subject: [PATCH 04/49] changed ->d so that it only checks the contract just above, not many above svn: r12986 --- collects/scheme/private/contract-arrow.ss | 106 +++++++++++----------- collects/tests/mzscheme/contract-test.ss | 28 +++++- 2 files changed, 79 insertions(+), 55 deletions(-) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 0fcf37a5df..fcda331ffa 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -903,19 +903,6 @@ v4 todo: [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str) (loop (cdr args) (cdr non-kwd-ctcs)))])))))] - [check-and-mark - (λ (marks) - (when (->d-pre-cond ->d-stct) - (unless (apply (->d-pre-cond ->d-stct) dep-pre-args) - (raise-contract-error val - src-info - neg-blame - orig-str - "#:pre-cond violation"))) - (if marks - (with-continuation-mark ->d-tail-key (cons this->d-id marks) - (thunk)) - (thunk)))] [rng (let ([rng (->d-range ->d-stct)]) (cond [(not rng) #f] @@ -924,50 +911,61 @@ v4 todo: (unbox rng))] [else rng]))] [rng-underscore? (box? (->d-range ->d-stct))]) + (when (->d-pre-cond ->d-stct) + (unless (apply (->d-pre-cond ->d-stct) dep-pre-args) + (raise-contract-error val + src-info + neg-blame + orig-str + "#:pre-cond violation"))) (call-with-immediate-continuation-mark ->d-tail-key (λ (first-mark) - (if (and rng - (not (and first-mark - (member this->d-id first-mark)))) - (call-with-values - (λ () (check-and-mark (or first-mark '()))) - (λ orig-results - (let* ([range-count (length rng)] - [post-args (append orig-results raw-orig-args)] - [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] - [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count - post-args (->d-rest-ctc ->d-stct) - (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) - (when (->d-post-cond ->d-stct) - (unless (apply (->d-post-cond ->d-stct) dep-post-args) - (raise-contract-error val - src-info - pos-blame - orig-str - "#:post-cond violation"))) - - (unless (= range-count (length orig-results)) - (raise-contract-error val - src-info - pos-blame - orig-str - "expected ~a results, got ~a" - range-count - (length orig-results))) - (apply - values - (let loop ([results orig-results] - [result-contracts rng]) - (cond - [(null? result-contracts) '()] - [else - (cons - (invoke-dep-ctc (car result-contracts) - (if rng-underscore? #f dep-post-args) - (car results) pos-blame neg-blame src-info orig-str) - (loop (cdr results) (cdr result-contracts)))])))))) - (check-and-mark #f))))))]) + (cond + [(and rng + (not (and first-mark + (eq? this->d-id first-mark)))) + (call-with-values + (λ () + (with-continuation-mark ->d-tail-key this->d-id + (thunk))) + (λ orig-results + (let* ([range-count (length rng)] + [post-args (append orig-results raw-orig-args)] + [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] + [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count + post-args (->d-rest-ctc ->d-stct) + (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) + (when (->d-post-cond ->d-stct) + (unless (apply (->d-post-cond ->d-stct) dep-post-args) + (raise-contract-error val + src-info + pos-blame + orig-str + "#:post-cond violation"))) + + (unless (= range-count (length orig-results)) + (raise-contract-error val + src-info + pos-blame + orig-str + "expected ~a results, got ~a" + range-count + (length orig-results))) + (apply + values + (let loop ([results orig-results] + [result-contracts rng]) + (cond + [(null? result-contracts) '()] + [else + (cons + (invoke-dep-ctc (car result-contracts) + (if rng-underscore? #f dep-post-args) + (car results) pos-blame neg-blame src-info orig-str) + (loop (cdr results) (cdr result-contracts)))]))))))] + [else + (thunk)])))))]) (make-keyword-procedure kwd-proc ((->d-name-wrapper ->d-stct) (λ args diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index bdbba39713..fc83a58021 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -5265,7 +5265,11 @@ so that propagation occurs. (f 3)) (c))) - (ctest '(1 1) + ;; the tail-call optimization cannot handle two different + ;; contracts on the stack one after the other one, so this + ;; returns '(4 4) instead of '(1 1) (which would indicate + ;; the optimization had happened). + (ctest '(4 4) 'tail->d-mut-rec (letrec ([odd-count 0] [pos-count 0] @@ -5318,6 +5322,28 @@ so that propagation occurs. (f 4)) (c))) + (ctest '(1) + 'mut-rec-with-any/c + (let () + (define f + (contract (-> number? any/c) + (lambda (x) + (if (zero? x) + (continuation-mark-set->list (current-continuation-marks) 'tail-test) + (with-continuation-mark 'tail-test x + (g (- x 1))))) + 'pos + 'neg)) + + (define g + (contract (-> number? any/c) + (lambda (x) + (f x)) + 'pos + 'neg)) + + (f 3))) + ; ; ; From 97e00eef977825268d02eb46daa0e8867d02824b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Jan 2009 16:57:46 +0000 Subject: [PATCH 05/49] fixed a bug in the ->d contract checking (wrt tail dropping) svn: r12987 --- collects/scheme/private/contract-arrow.ss | 5 ++- collects/tests/mzscheme/contract-test.ss | 48 +++++++++++++++++++++-- 2 files changed, 47 insertions(+), 6 deletions(-) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index fcda331ffa..ed9a29eda4 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -924,10 +924,11 @@ v4 todo: (cond [(and rng (not (and first-mark - (eq? this->d-id first-mark)))) + (eq? this->d-id (car first-mark)) + (andmap eq? raw-orig-args (cdr first-mark))))) (call-with-values (λ () - (with-continuation-mark ->d-tail-key this->d-id + (with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args) (thunk))) (λ orig-results (let* ([range-count (length rng)] diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index fc83a58021..d262306d9f 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -5243,8 +5243,10 @@ so that propagation occurs. (c))) - (ctest 2 - 'tail-arrow-d1 + ;; this one is not tail recursive, since the contract system + ;; cannot tell that the range contract doesn't depend on 'arg' + (ctest 8 + 'tail-arrow-d1/changing-args (let ([c (counter)]) (letrec ([f (contract (->d ([arg any/c]) () (values [_ c] [_ c])) @@ -5254,8 +5256,22 @@ so that propagation occurs. (f 3)) (c))) - (ctest 1 - 'tail-arrow-d2 + (ctest 2 + 'tail-arrow-d1 + (let ([c (counter)]) + (letrec ([x 5] + [f + (contract (->d ([arg any/c]) () (values [_ c] [_ c])) + (λ (_ignored) (if (zero? x) (values x x) (begin (set! x (- x 1)) (f _ignored)))) + 'pos + 'neg)]) + (f 'ignored)) + (c))) + + + ;; this one is just like the one two above. + (ctest 4 + 'tail-arrow-d2/changing-args (let ([c (counter)]) (letrec ([f (contract (->d ([arg any/c]) () [rng c]) @@ -5265,6 +5281,18 @@ so that propagation occurs. (f 3)) (c))) + (ctest 1 + 'tail-arrow-d2 + (let ([c (counter)]) + (letrec ([x 3] + [f + (contract (->d ([arg any/c]) () [rng c]) + (λ (ignored) (if (zero? x) x (begin (set! x (- x 1)) (f ignored)))) + 'pos + 'neg)]) + (f 3)) + (c))) + ;; the tail-call optimization cannot handle two different ;; contracts on the stack one after the other one, so this ;; returns '(4 4) instead of '(1 1) (which would indicate @@ -5344,6 +5372,18 @@ so that propagation occurs. (f 3))) + (test/pos-blame 'free-vars-change-so-cannot-drop-the-check + '(let () + (define f + (contract (->d ([x number?]) () [_ ( Date: Sat, 3 Jan 2009 17:36:46 +0000 Subject: [PATCH 06/49] PR 9999: fixed color-list->image and alpha-color-list->image so that they accept zeros for the widths and heights svn: r12988 --- collects/htdp/image.ss | 99 +++++++++++++++------------ collects/tests/mzscheme/htdp-image.ss | 52 ++++++++++++++ 2 files changed, 107 insertions(+), 44 deletions(-) diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss index faad730c12..4c58afff08 100644 --- a/collects/htdp/image.ss +++ b/collects/htdp/image.ss @@ -927,72 +927,83 @@ converting from the computer's coordinates, we get: (define (color-list->image cl in-w in-h px py) (check 'color-list->image color-list? cl "list-of-colors" "first") - (check-posi-size 'color-list->image in-w "second") - (check-posi-size 'color-list->image in-h "third") + (check-size/0 'color-list->image in-w "second") + (check-size/0 'color-list->image in-h "third") (check-coordinate 'color-list->image px "fourth") (check-coordinate 'color-list->image py "fifth") (let ([w (inexact->exact in-w)] [h (inexact->exact in-h)]) - (unless (and (< 0 w 10000) (< 0 h 10000)) - (error 'color-list->image "cannot make ~a x ~a image" w h)) + (unless (= (* w h) (length cl)) (error 'color-list->image "given width times given height is ~a, but the given color list has ~a items" (* w h) (length cl))) - (let* ([bm (make-object bitmap% w h)] - [mask-bm (make-object bitmap% w h)] - [dc (make-object bitmap-dc% bm)] - [mask-dc (make-object bitmap-dc% mask-bm)]) - (unless (send bm ok?) - (error (format "cannot make ~a x ~a image" w h))) - (let ([is (make-bytes (* 4 w h) 0)] - [mask-is (make-bytes (* 4 w h) 0)] - [cols (list->vector (map (λ (x) - (or (make-color% x) - (error 'color-list->image "color ~e is unknown" x))) - cl))]) - (let yloop ([y 0][pos 0]) - (unless (= y h) - (let xloop ([x 0][pos pos]) - (if (= x w) - (yloop (add1 y) pos) - (let* ([col (vector-ref cols (+ x (* y w)))] - [r (pk (send col red))] - [g (pk (send col green))] - [b (pk (send col blue))]) - (bytes-set! is (+ 1 pos) r) - (bytes-set! is (+ 2 pos) g) - (bytes-set! is (+ 3 pos) b) - (when (= 255 r g b) - (bytes-set! mask-is (+ 1 pos) 255) - (bytes-set! mask-is (+ 2 pos) 255) - (bytes-set! mask-is (+ 3 pos) 255)) - (xloop (add1 x) (+ pos 4))))))) - (send dc set-argb-pixels 0 0 w h is) - (send mask-dc set-argb-pixels 0 0 w h mask-is)) - (send dc set-bitmap #f) - (send mask-dc set-bitmap #f) - (bitmaps->cache-image-snip bm mask-bm px py)))) + + (cond + [(or (equal? w 0) (equal? h 0)) + (put-pinhole (rectangle w h 'solid 'black) px py)] + [else + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error 'color-list->image "cannot make ~a x ~a image" w h)) + + (let* ([bm (make-object bitmap% w h)] + [mask-bm (make-object bitmap% w h)] + [dc (make-object bitmap-dc% bm)] + [mask-dc (make-object bitmap-dc% mask-bm)]) + (unless (send bm ok?) + (error (format "cannot make ~a x ~a image" w h))) + (let ([is (make-bytes (* 4 w h) 0)] + [mask-is (make-bytes (* 4 w h) 0)] + [cols (list->vector (map (λ (x) + (or (make-color% x) + (error 'color-list->image "color ~e is unknown" x))) + cl))]) + (let yloop ([y 0][pos 0]) + (unless (= y h) + (let xloop ([x 0][pos pos]) + (if (= x w) + (yloop (add1 y) pos) + (let* ([col (vector-ref cols (+ x (* y w)))] + [r (pk (send col red))] + [g (pk (send col green))] + [b (pk (send col blue))]) + (bytes-set! is (+ 1 pos) r) + (bytes-set! is (+ 2 pos) g) + (bytes-set! is (+ 3 pos) b) + (when (= 255 r g b) + (bytes-set! mask-is (+ 1 pos) 255) + (bytes-set! mask-is (+ 2 pos) 255) + (bytes-set! mask-is (+ 3 pos) 255)) + (xloop (add1 x) (+ pos 4))))))) + (send dc set-argb-pixels 0 0 w h is) + (send mask-dc set-argb-pixels 0 0 w h mask-is)) + (send dc set-bitmap #f) + (send mask-dc set-bitmap #f) + (bitmaps->cache-image-snip bm mask-bm px py))]))) (define (pk col) (min 255 (max 0 col))) (define (alpha-color-list->image cl in-w in-h px py) (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first") - (check-posi-size 'alpha-color-list->image in-w "second") - (check-posi-size 'alpha-color-list->image in-h "third") + (check-size/0 'alpha-color-list->image in-w "second") + (check-size/0 'alpha-color-list->image in-h "third") (check-coordinate 'alpha-color-list->image px "fourth") (check-coordinate 'alpha-color-list->image py "fifth") (let ([w (inexact->exact in-w)] [h (inexact->exact in-h)]) - (unless (and (< 0 w 10000) (< 0 h 10000)) - (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h)) (unless (= (* w h) (length cl)) (error 'alpha-color-list->image "given width times given height is ~a, but the given color list has ~a items" (* w h) (length cl))) - (let ([index-list (alpha-colors->ent-list cl)]) - (argb->cache-image-snip (make-argb (list->vector index-list) w h) px py)))) + (cond + [(or (equal? w 0) (equal? h 0)) + (put-pinhole (rectangle w h 'solid 'black) px py)] + [else + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h)) + (let ([index-list (alpha-colors->ent-list cl)]) + (argb->cache-image-snip (make-argb (list->vector index-list) w h) px py))]))) ;; alpha-colors->ent-list : (listof alpha-color) -> (listof number) (define (alpha-colors->ent-list cl) diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss index 4b0469c9d9..2a0bd8db84 100644 --- a/collects/tests/mzscheme/htdp-image.ss +++ b/collects/tests/mzscheme/htdp-image.ss @@ -201,6 +201,32 @@ (image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2 0 0) (p00 (rectangle 2 2 'solid 'blue)))) +(test 10 + 'color-list8 + (image-width (color-list->image '() 10 0 0 0))) + +(test 0 + 'color-list9 + (image-height (color-list->image '() 10 0 0 0))) + +(test 0 + 'color-list10 + (image-width (color-list->image '() 0 10 0 0))) + +(test 10 + 'color-list11 + (image-height (color-list->image '() 0 10 0 0))) + +(test 3 + 'color-list12 + (pinhole-x (color-list->image '() 10 0 3 0))) + +(test 3 + 'color-list13 + (pinhole-y (color-list->image '() 0 10 0 3))) + + + (test #t 'alpha-color-list1 (equal? (make-alpha-color 0 255 0 0) @@ -278,6 +304,32 @@ blue blue blue red blue red))) +(test 10 + 'alpha-color-list11 + (image-width (alpha-color-list->image '() 10 0 0 0))) + +(test 0 + 'alpha-color-list12 + (image-height (alpha-color-list->image '() 10 0 0 0))) + +(test 0 + 'alpha-color-list13 + (image-width (alpha-color-list->image '() 0 10 0 0))) + +(test 10 + 'alpha-color-list14 + (image-height (alpha-color-list->image '() 0 10 0 0))) + + +(test 3 + 'alpha-color-list15 + (pinhole-x (alpha-color-list->image '() 10 0 3 0))) + +(test 3 + 'alpha-color-list16 + (pinhole-y (alpha-color-list->image '() 0 10 0 3))) + + (test #t 'image=?1 (image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0) From 91801b4601b728e9169e7729741ac380e3a767ae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Jan 2009 17:51:06 +0000 Subject: [PATCH 07/49] fix algorithmic problem with syntax certificates (so Oleg's syntax-rules stress test runs in reasonable time) svn: r12990 --- collects/r5rs/main.ss | 18 +-- collects/r6rs/private/prelims.ss | 3 +- src/mzscheme/src/eval.c | 6 + src/mzscheme/src/module.c | 3 + src/mzscheme/src/schpriv.h | 14 ++- src/mzscheme/src/stxobj.c | 201 ++++++++++++++++++------------- src/mzscheme/src/syntax.c | 4 +- 7 files changed, 151 insertions(+), 98 deletions(-) diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index e44267bdc0..a17f5120d2 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -151,6 +151,14 @@ ;; -------------------------------------------------- + (define (to-mutable v) + (cond + [(pair? v) (mcons (to-mutable (car v)) + (to-mutable (cdr v)))] + [(vector? v) (list->vector + (map to-mutable (vector->list v)))] + [else v])) + (define-syntax (r5rs:quote stx) (syntax-case stx () [(_ form) @@ -162,15 +170,7 @@ (ormap loop (syntax->list #'(a ...)))] [_ #f])) ;; quote has to create mpairs: - (syntax-local-lift-expression (let loop ([form #'form]) - (syntax-case form () - [(a ...) - #`(mlist . #,(map loop (syntax->list #'(a ...))))] - [(a . b) - #`(mcons #,(loop #'a) #,(loop #'b))] - [#(a ...) - #`(vector . #,(map loop (syntax->list #'(a ...))))] - [other #'(quote other)]))) + (syntax-local-lift-expression #'(to-mutable 'form)) ;; no pairs to worry about: #'(quote form))])) diff --git a/collects/r6rs/private/prelims.ss b/collects/r6rs/private/prelims.ss index 11d51d5ddb..555c8c2463 100644 --- a/collects/r6rs/private/prelims.ss +++ b/collects/r6rs/private/prelims.ss @@ -6,7 +6,8 @@ (provide (rename-out [datum #%datum]) - #%app #%top #%top-interaction) + (rename-out [#%plain-app #%app]) + #%top #%top-interaction) ;; ---------------------------------------- ;; Datum diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 70013d0363..a90f03d47d 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -4643,6 +4643,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, dest[i].comp = 1; dest[i].dont_mark_local_use = src[drec].dont_mark_local_use; dest[i].resolve_module_ids = src[drec].resolve_module_ids; + dest[i].no_module_cert = src[drec].no_module_cert; dest[i].value_name = scheme_false; dest[i].certs = src[drec].certs; /* should be always NULL */ @@ -4668,6 +4669,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, dest[i].certs = src[drec].certs; dest[i].observer = src[drec].observer; dest[i].pre_unwrapped = 0; + dest[i].no_module_cert = src[drec].no_module_cert; dest[i].env_already = 0; dest[i].comp_flags = src[drec].comp_flags; } @@ -4688,6 +4690,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, lam[dlrec].comp = 1; lam[dlrec].dont_mark_local_use = src[drec].dont_mark_local_use; lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids; + lam[dlrec].no_module_cert = src[drec].no_module_cert; lam[dlrec].value_name = scheme_false; lam[dlrec].certs = src[drec].certs; lam[dlrec].observer = src[drec].observer; @@ -4955,6 +4958,7 @@ static void *compile_k(void) rec.comp = 1; rec.dont_mark_local_use = 0; rec.resolve_module_ids = !writeable && !genv->module; + rec.no_module_cert = 0; rec.value_name = scheme_false; rec.certs = NULL; rec.observer = NULL; @@ -8868,6 +8872,7 @@ static void *expand_k(void) erec1.certs = certs; erec1.observer = observer; erec1.pre_unwrapped = 0; + erec1.no_module_cert = 0; erec1.env_already = 0; erec1.comp_flags = comp_flags; @@ -9720,6 +9725,7 @@ local_eval(int argc, Scheme_Object **argv) rec.certs = certs; rec.observer = observer; rec.pre_unwrapped = 0; + rec.no_module_cert = 0; rec.env_already = 0; rec.comp_flags = get_comp_flags(NULL); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 581bc8569f..bc37315a16 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -5960,6 +5960,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, erec1.certs = rec[drec].certs; erec1.observer = rec[drec].observer; erec1.pre_unwrapped = 0; + erec1.no_module_cert = 0; erec1.env_already = 0; erec1.comp_flags = rec[drec].comp_flags; e = scheme_expand_expr(e, xenv, &erec1, 0); @@ -6160,6 +6161,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, mrec.comp = 1; mrec.dont_mark_local_use = 0; mrec.resolve_module_ids = 0; + mrec.no_module_cert = 0; mrec.value_name = NULL; mrec.certs = rec[drec].certs; mrec.observer = NULL; @@ -6176,6 +6178,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, erec1.certs = mrec.certs; erec1.observer = rec[drec].observer; erec1.pre_unwrapped = 0; + erec1.no_module_cert = 0; erec1.env_already = 0; erec1.comp_flags = rec[drec].comp_flags; SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 231003d3e1..655e9be56e 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -845,7 +845,8 @@ Scheme_Object *scheme_source_to_name(Scheme_Object *code); Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env *menv, Scheme_Object *plus_stx, Scheme_Object *mkey, int active); -int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs, Scheme_Object *modidx, Scheme_Object *home_insp); +int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs, + Scheme_Object *modidx, Scheme_Object *home_insp); int scheme_module_protected_wrt(Scheme_Object *home_insp, Scheme_Object *insp); Scheme_Object *scheme_stx_activate_certs(Scheme_Object *stx); @@ -853,7 +854,7 @@ Scheme_Object *scheme_stx_extract_certs(Scheme_Object *o, Scheme_Object *base_ce Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *certs); Scheme_Object *scheme_stx_propagate_inactive_certs(Scheme_Object *o, Scheme_Object *orig); -int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *certs, +int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *certs, Scheme_Object *than_id, Scheme_Object *than_certs); Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i); @@ -1073,10 +1074,10 @@ typedef struct Scheme_Dynamic_State { } Scheme_Dynamic_State; void scheme_set_dynamic_state(Scheme_Dynamic_State *state, struct Scheme_Comp_Env *env, Scheme_Object *mark, - Scheme_Object *name, - Scheme_Object *certs, - Scheme_Env *menv, - Scheme_Object *modidx); + Scheme_Object *name, + Scheme_Object *certs, + Scheme_Env *menv, + Scheme_Object *modidx); void *scheme_top_level_do(void *(*k)(void), int eb); void *scheme_top_level_do_worker(void *(*k)(void), int eb, int newthread, Scheme_Dynamic_State *dyn_state); @@ -1851,6 +1852,7 @@ typedef struct Scheme_Compile_Expand_Info char dont_mark_local_use; char resolve_module_ids; char pre_unwrapped; + char no_module_cert; int depth; int env_already; } Scheme_Compile_Expand_Info; diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 2d7a8d2d80..a3854bbd06 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -2322,6 +2322,9 @@ static void make_mapped(Scheme_Cert *cert) Scheme_Object *pr; Scheme_Hash_Table *ht; + if (cert->mapped) + return; + #ifdef DO_STACK_CHECK { # include "mzstkchk.h" @@ -2335,9 +2338,6 @@ static void make_mapped(Scheme_Cert *cert) #endif SCHEME_USE_FUEL(1); - if (cert->mapped) - return; - if (cert->depth == 16) { stop = NULL; } else { @@ -2403,18 +2403,32 @@ static int cert_in_chain(Scheme_Object *mark, Scheme_Object *key, Scheme_Cert *c static Scheme_Cert *append_certs(Scheme_Cert *a, Scheme_Cert *b) { + Scheme_Cert *c; + if (!a) return b; if (!b) return a; if (a->depth < b->depth) { - Scheme_Cert *c = a; + c = a; a = b; b = c; } + c = a; + if (b->depth > (a->depth >> 1)) { + /* There's a good chance that b shares a tail with a, + so check for that, and b is large enough relative to + a that it's worth iterating down to b's depth in a: */ + while (c->depth > b->depth) { + c = c->next; + } + } + for (; b; b = b->next) { + if (b == c) break; if (!cert_in_chain(b->mark, b->key, a)) a = cons_cert(b->mark, b->modidx, b->insp, b->key, a); + c = c->next; } return a; @@ -2422,10 +2436,10 @@ static Scheme_Cert *append_certs(Scheme_Cert *a, Scheme_Cert *b) static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active) { - Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs; + Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs, *check_tail; Scheme_Stx *stx = (Scheme_Stx *)o, *res; Scheme_Object *pr; - int copy_on_write, shortcut; + int shortcut; if (!stx->certs) { if (!certs) @@ -2455,7 +2469,6 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj } } - copy_on_write = 1; if (active) orig_certs = ACTIVE_CERTS(stx); else @@ -2465,61 +2478,66 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj shortcut = 0; if (now_certs && certs && !use_key && CERT_NO_KEY(certs)) { if (now_certs->depth < certs->depth) { - /* Maybe we can add now_certs onto certs, instead of the other + /* We can add now_certs onto certs, instead of the other way around. */ - for (next_certs = certs; next_certs; next_certs = next_certs->next) { - if (cert_in_chain(next_certs->mark, use_key, now_certs)) { - break; - } - } - if (!next_certs) { - /* Yes, we can take that shortcut. */ - certs = append_certs(now_certs, certs); - now_certs = NULL; - shortcut = 1; + now_certs = certs; + certs = orig_certs; + } + } + + check_tail = now_certs; + if (check_tail && certs + && (certs->depth > (check_tail->depth >> 1))) { + while (check_tail->depth > certs->depth) { + check_tail = check_tail->next; + } + } + + for (; certs; certs = next_certs) { + next_certs = certs->next; + if (check_tail && (check_tail->depth > certs->depth)) + check_tail = check_tail->next; + if (SAME_OBJ(certs, check_tail)) { + /* tails match --- no need to keep checking */ + break; + } + if (!cert_in_chain(certs->mark, use_key, now_certs)) { + if (!now_certs && !use_key && (shortcut || CERT_NO_KEY(certs))) { + now_certs = certs; + next_certs = NULL; + } else { + now_certs = cons_cert(certs->mark, certs->modidx, certs->insp, use_key, + now_certs); } } } - for (; certs; certs = next_certs) { - next_certs = certs->next; - if (!cert_in_chain(certs->mark, use_key, now_certs)) { - if (copy_on_write) { - res = (Scheme_Stx *)scheme_make_stx(stx->val, - stx->srcloc, - stx->props); - res->wraps = stx->wraps; - res->u.lazy_prefix = stx->u.lazy_prefix; - if (!active) { - pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs); - res->certs = pr; - if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs)) - SCHEME_SET_IMMUTABLE(pr); - } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) { - pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs)); - res->certs = pr; - if (SCHEME_IMMUTABLEP(stx->certs)) - SCHEME_SET_IMMUTABLE(pr); - } else - res->certs = (Scheme_Object *)orig_certs; - stx = res; - copy_on_write = 0; - } - if (!now_certs && !use_key && (shortcut || CERT_NO_KEY(certs))) { - cl = certs; - next_certs = NULL; - } else { - cl = cons_cert(certs->mark, certs->modidx, certs->insp, use_key, - active ? ACTIVE_CERTS(stx) : INACTIVE_CERTS(stx)); - } - now_certs = cl; - if (!active) { - SCHEME_CDR(stx->certs) = (Scheme_Object *)cl; - } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) - SCHEME_CAR(stx->certs) = (Scheme_Object *)cl; - else - stx->certs = (Scheme_Object *)cl; - } + if (!SAME_OBJ(now_certs, orig_certs)) { + res = (Scheme_Stx *)scheme_make_stx(stx->val, + stx->srcloc, + stx->props); + res->wraps = stx->wraps; + res->u.lazy_prefix = stx->u.lazy_prefix; + if (!active) { + pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs); + res->certs = pr; + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs)) + SCHEME_SET_IMMUTABLE(pr); + } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) { + pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs)); + res->certs = pr; + if (SCHEME_IMMUTABLEP(stx->certs)) + SCHEME_SET_IMMUTABLE(pr); + } else + res->certs = (Scheme_Object *)orig_certs; + stx = res; + + if (!active) { + SCHEME_CDR(stx->certs) = (Scheme_Object *)now_certs; + } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) + SCHEME_CAR(stx->certs) = (Scheme_Object *)now_certs; + else + stx->certs = (Scheme_Object *)now_certs; } return (Scheme_Object *)stx; @@ -3346,7 +3364,15 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks) } } -static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache) +#define EXPLAIN_RESOLVE 0 +#if EXPLAIN_RESOLVE +static int explain_resolves = 0; +# define EXPLAIN(x) if (explain_resolves) { x; } +#else +# define EXPLAIN(x) /* empty */ +#endif + +static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth) { int l1, l2; Scheme_Object *m1, *m2; @@ -3355,11 +3381,14 @@ static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme p = SCHEME_CDR(p); /* skip phase_export */ if (SCHEME_PAIRP(p)) { /* has marks */ + + EXPLAIN(fprintf(stderr, "%d has marks\n", depth)); m1 = SCHEME_CAR(p); if (*marks_cache) m2 = *marks_cache; else { + EXPLAIN(fprintf(stderr, "%d extract marks\n", depth)); m2 = scheme_stx_extract_marks(orig_id); *marks_cache = m2; } @@ -3382,9 +3411,10 @@ static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme return 0; /* match empty mark set */ } -static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, - Scheme_Object *glob_id, Scheme_Object *orig_id, - Scheme_Object **get_names, int get_orig_name) +static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, + Scheme_Object *glob_id, Scheme_Object *orig_id, + Scheme_Object **get_names, int get_orig_name, + int depth) { Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL; Scheme_Module_Phase_Exports *pt; @@ -3395,8 +3425,11 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr)); + EXPLAIN(fprintf(stderr, "%d pes table\n", depth)); + if (!pt->ht) { /* Lookup table (which is created lazily) not yet created, so do that now... */ + EXPLAIN(fprintf(stderr, "%d {create lookup}\n", depth)); ht = scheme_make_hash_table(SCHEME_hash_ptr); for (i = pt->num_provides; i--; ) { scheme_hash_set(ht, pt->provides[i], scheme_make_integer(i)); @@ -3408,7 +3441,8 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, if (pos) { /* Found it, maybe. Check marks. */ int mark_len; - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache); + EXPLAIN(fprintf(stderr, "%d found %p\n", depth, pos)); + mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth); if (mark_len > best_match_len) { /* Marks match and improve on previously found match. Build suitable rename: */ best_match_len = mark_len; @@ -3462,7 +3496,7 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, if (kpr) { /* Found it, maybe. Check marks. */ int mark_len; - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache); + mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth); if (mark_len > best_match_len) { /* Marks match and improve on previously found match. Build suitable rename: */ best_match_len = mark_len; @@ -3491,9 +3525,9 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object *phase) { - if (SCHEME_INTP(phase) && (SCHEME_INT_VAL(phase) == 0)) + if (SAME_OBJ(phase, scheme_make_integer(0))) return mrns->rt; - else if (SCHEME_INTP(phase) && (SCHEME_INT_VAL(phase) == 1)) + else if (SAME_OBJ(phase, scheme_make_integer(1))) return mrns->et; else if (mrns->other_phases) return (Module_Renames *)scheme_hash_get(mrns->other_phases, phase); @@ -3530,15 +3564,7 @@ static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip return scheme_make_raw_pair(timestamp, skip_ribs); } -#define QUICK_STACK_SIZE 10 - -#define EXPLAIN_RESOLVE 0 -#if EXPLAIN_RESOLVE -static int explain_resolves = 0; -# define EXPLAIN(x) if (explain_resolves) { x; } -#else -# define EXPLAIN(x) /* empty */ -#endif +#define QUICK_STACK_SIZE 8 /* Although resolve_env may call itself recursively, the recursion depth is bounded (by the fact that modules can't be nested, @@ -3656,8 +3682,6 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) && !skip_other_mods) { - EXPLAIN(fprintf(stderr, "%d use rename %p %d\n", depth, mrn->phase, mrn->kind)); - if (mrn->kind != mzMOD_RENAME_TOPLEVEL) is_in_module = 1; @@ -3665,12 +3689,18 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *rename, *nominal = NULL, *glob_id; int get_names_done; - if (mrn->needs_unmarshal) + EXPLAIN(fprintf(stderr, "%d use rename %p %d\n", depth, mrn->phase, mrn->kind)); + + if (mrn->needs_unmarshal) { + EXPLAIN(fprintf(stderr, "%d {unmarshal}\n", depth)); unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry); + } if (mrn->marked_names) { /* Resolve based on rest of wraps: */ + EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); if (!bdg) { + EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL, NULL, depth+1); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { @@ -3709,7 +3739,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } get_names_done = 0; if (!rename) { - rename = scheme_search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0); + EXPLAIN(fprintf(stderr, "%d in pes\n", depth)); + rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth); if (rename) get_names_done = 1; } @@ -3820,6 +3851,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps)) && w_mod) { /* Phase shift */ Scheme_Object *vec, *n, *dest, *src; + + EXPLAIN(fprintf(stderr, "%d phase shift\n", depth)); + vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); n = SCHEME_VEC_ELS(vec)[0]; if (SCHEME_TRUEP(phase)) @@ -3864,7 +3898,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, is_rib = NULL; } - EXPLAIN(fprintf(stderr, "%d lexical rename (%d)\n", depth, is_rib ? 1 : 0)); + EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d%s\n", depth, is_rib ? 1 : 0, + SCHEME_VEC_SIZE(rename), + SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash")); c = SCHEME_RENAME_LEN(rename); @@ -3992,6 +4028,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) { Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps); + EXPLAIN(fprintf(stderr, "%d forwarding table...\n", depth)); + did_rib = NULL; if (!ht->count @@ -4001,6 +4039,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } if (!scheme_hash_get(ht, SCHEME_STX_VAL(a))) { + EXPLAIN(fprintf(stderr, "%d forwarded\n", depth)); set_wraps_to_skip(ht, &wraps); continue; /* <<<<< ------ */ @@ -4108,7 +4147,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ rename = scheme_hash_get(krn->ht, glob_id); if (!rename) - result = scheme_search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1); + result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0); else { /* match; set result: */ if (mrn->kind == mzMOD_RENAME_MARKED) @@ -4211,7 +4250,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, names[5] = NULL; modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, NULL, 0); - + if (names[0]) { if (SAME_OBJ(names[0], scheme_undefined)) { return scheme_undefined; diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 4484b91f90..106b3f1c87 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -5189,7 +5189,7 @@ quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_In /* Push all certificates in the environment down to the syntax object. */ stx = scheme_stx_add_inactive_certs(stx, rec[drec].certs); - if (env->genv->module) { + if (env->genv->module && !rec[drec].no_module_cert) { /* Also certify access to the enclosing module: */ stx = scheme_stx_cert(stx, scheme_false, env->genv, NULL, NULL, 0); } @@ -5561,6 +5561,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, rec1.comp = 1; rec1.dont_mark_local_use = 0; rec1.resolve_module_ids = 0; + rec1.no_module_cert = 0; rec1.value_name = NULL; rec1.certs = rec[drec].certs; rec1.observer = NULL; @@ -5753,6 +5754,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object mrec.comp = 1; mrec.dont_mark_local_use = 0; mrec.resolve_module_ids = 1; + mrec.no_module_cert = 1; mrec.value_name = NULL; mrec.certs = certs; mrec.observer = NULL; From 05e66120efdce7d1bb0aab9cb94568c7bae22dd5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Jan 2009 17:58:20 +0000 Subject: [PATCH 08/49] look up owner table after call to custodian_to_owner_set svn: r12991 --- src/mzscheme/gc2/mem_account.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c index 74bc79e794..67eb15fe33 100644 --- a/src/mzscheme/gc2/mem_account.c +++ b/src/mzscheme/gc2/mem_account.c @@ -466,6 +466,7 @@ static void BTC_do_accounting(NewGC *gc) if (parent) { int powner = custodian_to_owner_set(gc, parent); + owner_table = gc->owner_table; owner_table[powner]->memory_use += owner_table[owner]->memory_use; } From d596401804242ca39007e56d798e12f3852810f0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Jan 2009 18:51:15 +0000 Subject: [PATCH 09/49] scheme/foreign: allow #f as NULL function pointer, allow callback as cpointer svn: r12992 --- collects/mzlib/foreign.ss | 19 ++-- collects/scribblings/foreign/pointers.scrbl | 2 +- collects/scribblings/foreign/types.scrbl | 8 +- collects/tests/mzscheme/foreign-test.c | 2 +- collects/tests/mzscheme/foreign-test.ss | 2 + src/foreign/foreign.c | 111 ++++++++++---------- src/foreign/foreign.ssc | 27 ++--- 7 files changed, 91 insertions(+), 80 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 5c04be9b6d..4d999cebbe 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -477,15 +477,16 @@ (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) - (let ([cb (ffi-callback (wrap x) itypes otype abi)]) - (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] - [(box? keep) - (let ([x (unbox keep)]) - (set-box! keep - (if (or (null? x) (pair? x)) (cons cb x) cb)))] - [(procedure? keep) (keep cb)]) - cb)) - (lambda (x) (wrap (ffi-call x itypes otype abi))))) + (and x + (let ([cb (ffi-callback (wrap x) itypes otype abi)]) + (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] + [(box? keep) + (let ([x (unbox keep)]) + (set-box! keep + (if (or (null? x) (pair? x)) (cons cb x) cb)))] + [(procedure? keep) (keep cb)]) + cb))) + (lambda (x) (and x (wrap (ffi-call x itypes otype abi)))))) (if wrapper (make-it wrapper) (make-it begin))) ;; Syntax for the special _fun type: diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index 1dc0ed1314..342b31991f 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -7,7 +7,7 @@ Returns @scheme[#t] if @scheme[v] is a C pointer or a value that can be used as a pointer: @scheme[#f] (used as a @cpp{NULL} pointer), byte -strings (used as memory blocks), some additional internal objects +strings (used as memory blocks), or some additional internal objects (@scheme[ffi-obj]s and callbacks, see @secref["foreign:c-only"]). Returns @scheme[#f] for other values.} diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 44975a2e96..e894102004 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -282,9 +282,9 @@ PLT Scheme's C API.} Similar to @scheme[_pointer], except that when an @scheme[_fpointer] is extracted from a pointer produced by @scheme[ffi-obj-ref], then a level of indirection is skipped. A level of indirection is similarly -skipped when extracting a pointer via @scheme[get-ffi-obj]. Also -unlike @scheme[_pointer], @scheme[_fpointer] does not convert -@scheme[#f] to @cpp{NULL}. +skipped when extracting a pointer via @scheme[get-ffi-obj]. Like +@scheme[_pointer], @scheme[_fpointer] treats @scheme[#f] as @cpp{NULL} +and vice-versa. A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer], and normally @scheme[_cprocedure] should be used instead of @@ -312,6 +312,8 @@ The resulting type can be used to reference foreign functions (usually @scheme[ffi-obj]s, but any pointer object can be referenced with this type), generating a matching foreign callout object. Such objects are new primitive procedure objects that can be used like any other Scheme procedure. +As with other pointer types, @scheme[#f] is treated as a @cpp{NULL} +function pointer and vice-versa. A type created with @scheme[_cprocedure] can also be used for passing Scheme procedures to foreign functions, which will generate a foreign diff --git a/collects/tests/mzscheme/foreign-test.c b/collects/tests/mzscheme/foreign-test.c index d0da456d43..b14d713a4b 100644 --- a/collects/tests/mzscheme/foreign-test.c +++ b/collects/tests/mzscheme/foreign-test.c @@ -21,7 +21,7 @@ X byte decimal_byte_int_byte (byte x, int y) { return 10*x + y; } X byte decimal_int_byte_byte (int x, byte y) { return 10*x + y; } X byte decimal_byte_byte_byte (byte x, byte y) { return 10*x + y; } -X int callback3_int_int_int (int(*f)(int)) { return f(3); } +X int callback3_int_int_int (int(*f)(int)) { if (f) return f(3); else return 79; } X int callback3_byte_int_int (int(*f)(byte)) { return f(3); } X int callback3_int_byte_int (byte(*f)(int)) { return f(3); } X int callback3_byte_byte_int (byte(*f)(byte)) { return f(3); } diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index c55ab2c358..dc1c7cfb84 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -77,6 +77,8 @@ (t 12 'decimal_byte_byte_byte (_fun _byte _byte -> _byte) 1 2) ;; --- (t 9 'callback3_int_int_int (_fun (_fun _int -> _int ) -> _int ) sqr) + (t 79 'callback3_int_int_int (_fun (_fun _int -> _int ) -> _int ) #f) ; NULL allowed as function pointer + (t 9 'callback3_int_int_int (_fun _pointer -> _int ) (function-ptr sqr (_fun _int -> _int ))) ; callback allowed as pointer (t 9 'callback3_byte_int_int (_fun (_fun _byte -> _int ) -> _int ) sqr) (t 9 'callback3_int_byte_int (_fun (_fun _int -> _byte) -> _int ) sqr) (t 9 'callback3_byte_byte_int (_fun (_fun _byte -> _byte) -> _int ) sqr) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 6d927005b6..155e4e7716 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -1097,58 +1097,6 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[]) return (Scheme_Object*)type; } -/*****************************************************************************/ -/* Pointer objects */ -/* use cpointer (with a NULL tag when creating), #f for NULL */ - -#define SCHEME_FFIANYPTRP(x) \ - (SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \ - SCHEME_BYTE_STRINGP(x)) -#define SCHEME_FFIANYPTR_VAL(x) \ - (SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \ - (SCHEME_FALSEP(x) ? NULL : \ - (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \ - SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \ - NULL))) -#define SCHEME_FFIANYPTR_OFFSET(x) \ - (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0) -#define SCHEME_FFIANYPTR_OFFSETVAL(x) \ - W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x)) - -#define SCHEME_CPOINTER_W_OFFSET_P(x) \ - SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type) - -#define scheme_make_foreign_cpointer(x) \ - ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) - -#undef MYNAME -#define MYNAME "cpointer?" -static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[]) -{ - return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; -} - -#undef MYNAME -#define MYNAME "cpointer-tag" -static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *tag = NULL; - if (!SCHEME_FFIANYPTRP(argv[0])) - scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); - if (SCHEME_CPTRP(argv[0])) tag = SCHEME_CPTR_TYPE(argv[0]); - return (tag == NULL) ? scheme_false : tag; -} - -#undef MYNAME -#define MYNAME "set-cpointer-tag!" -static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *argv[]) -{ - if (!SCHEME_CPTRP(argv[0])) - scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv); - SCHEME_CPTR_TYPE(argv[0]) = argv[1]; - return scheme_void; -} - /*****************************************************************************/ /* Callback type */ @@ -1190,6 +1138,59 @@ int ffi_callback_FIXUP(void *p) { END_XFORM_SKIP; #endif +/*****************************************************************************/ +/* Pointer objects */ +/* use cpointer (with a NULL tag when creating), #f for NULL */ + +#define SCHEME_FFIANYPTRP(x) \ + (SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \ + SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x)) +#define SCHEME_FFIANYPTR_VAL(x) \ + (SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \ + (SCHEME_FALSEP(x) ? NULL : \ + (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \ + (SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \ + (SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \ + NULL))))) +#define SCHEME_FFIANYPTR_OFFSET(x) \ + (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0) +#define SCHEME_FFIANYPTR_OFFSETVAL(x) \ + W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x)) + +#define SCHEME_CPOINTER_W_OFFSET_P(x) \ + SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type) + +#define scheme_make_foreign_cpointer(x) \ + ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) + +#undef MYNAME +#define MYNAME "cpointer?" +static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[]) +{ + return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; +} + +#undef MYNAME +#define MYNAME "cpointer-tag" +static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *tag = NULL; + if (!SCHEME_FFIANYPTRP(argv[0])) + scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); + if (SCHEME_CPTRP(argv[0])) tag = SCHEME_CPTR_TYPE(argv[0]); + return (tag == NULL) ? scheme_false : tag; +} + +#undef MYNAME +#define MYNAME "set-cpointer-tag!" +static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *argv[]) +{ + if (!SCHEME_CPTRP(argv[0])) + scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv); + SCHEME_CPTR_TYPE(argv[0]) = argv[1]; + return scheme_void; +} + /*****************************************************************************/ /* Scheme<-->C conversions */ @@ -1287,6 +1288,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, ((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val); else if (SCHEME_FFIOBJP(val)) ((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj; + else if (SCHEME_FALSEP(val)) + ((void**)W_OFFSET(dst,delta))[0] = NULL; else /* ((void**)W_OFFSET(dst,delta))[0] = val; */ scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val); } else switch (CTYPE_PRIMLABEL(type)) { @@ -2799,14 +2802,14 @@ void scheme_init_foreign(Scheme_Env *env) scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv); scheme_add_global("make-cstruct-type", scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 1), menv); + scheme_add_global("ffi-callback?", + scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv); scheme_add_global("cpointer?", scheme_make_prim_w_arity(foreign_cpointer_p, "cpointer?", 1, 1), menv); scheme_add_global("cpointer-tag", scheme_make_prim_w_arity(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv); scheme_add_global("set-cpointer-tag!", scheme_make_prim_w_arity(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv); - scheme_add_global("ffi-callback?", - scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv); scheme_add_global("ctype-sizeof", scheme_make_prim_w_arity(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv); scheme_add_global("ctype-alignof", diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 50e2f77854..da91591339 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -937,19 +937,29 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) return (Scheme_Object*)type; } +/*****************************************************************************/ +/* Callback type */ + +{:(cdefstruct ffi-callback + (callback "void*") + (proc "Scheme_Object*") + (itypes "Scheme_Object*") + (otype "Scheme_Object*")):} + /*****************************************************************************/ /* Pointer objects */ /* use cpointer (with a NULL tag when creating), #f for NULL */ #define SCHEME_FFIANYPTRP(x) \ (SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \ - SCHEME_BYTE_STRINGP(x)) + SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x)) #define SCHEME_FFIANYPTR_VAL(x) \ (SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \ (SCHEME_FALSEP(x) ? NULL : \ (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \ - SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \ - NULL))) + (SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \ + (SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \ + NULL))))) #define SCHEME_FFIANYPTR_OFFSET(x) \ (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0) #define SCHEME_FFIANYPTR_OFFSETVAL(x) \ @@ -983,15 +993,6 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) return scheme_void; } -/*****************************************************************************/ -/* Callback type */ - -{:(cdefstruct ffi-callback - (callback "void*") - (proc "Scheme_Object*") - (itypes "Scheme_Object*") - (otype "Scheme_Object*")):} - /*****************************************************************************/ /* Scheme<-->C conversions */ @@ -1068,6 +1069,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, ((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val); else if (SCHEME_FFIOBJP(val)) ((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj; + else if (SCHEME_FALSEP(val)) + ((void**)W_OFFSET(dst,delta))[0] = NULL; else /* ((void**)W_OFFSET(dst,delta))[0] = val; */ scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val); } else switch (CTYPE_PRIMLABEL(type)) { From 056e8a6bb145cf5f3bf5022012fffb35ff117d95 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 3 Jan 2009 19:07:32 +0000 Subject: [PATCH 10/49] macro-debugger: fixed PR 10000 (case of eval during expansion in module/pass1) fixed display of multiple terms in stepper svn: r12993 --- collects/macro-debugger/model/deriv-parser.ss | 4 ++-- collects/macro-debugger/view/step-display.ss | 8 ++++---- collects/macro-debugger/view/term-record.ss | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index 029041ccc4..8751731872 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -191,8 +191,8 @@ (NotReallyLocalAction ;; called 'expand' (not 'local-expand') within transformer - [(start (? EE)) - #f]) + [(start (? EE)) #f] + [(start (? CheckImmediateMacro)) #f]) (Prim (#:args e1 e2 rs) diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss index 7c80955ca2..5894078b63 100644 --- a/collects/macro-debugger/view/step-display.ss +++ b/collects/macro-debugger/view/step-display.ss @@ -107,13 +107,13 @@ (show-poststep step binders shift-table)])) (define/public (add-syntax stx - #:binders binders + #:binders [binders #f] #:shift-table [shift-table #f] - #:definites definites) + #:definites [definites null]) (send sbview add-syntax stx #:binder-table binders #:shift-table shift-table - #:definites (or definites null))) + #:definites definites)) (define/public (add-final stx error #:binders binders @@ -124,7 +124,7 @@ (send sbview add-syntax stx #:binder-table binders #:shift-table shift-table - #:definites (or definites null))) + #:definites definites)) (when error (add-error error))) diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index a963906da0..e924a05a0a 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -274,7 +274,7 @@ ;; display-initial-term : -> void (define/public (display-initial-term) - (send displayer add-syntax (wderiv-e1 deriv) #f null)) + (send displayer add-syntax (wderiv-e1 deriv))) ;; display-final-term : -> void (define/public (display-final-term) From b6312ff3ca2765dcb132f5e740803e2dcdd6edfa Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 3 Jan 2009 19:58:06 +0000 Subject: [PATCH 11/49] macro stepper tests: added regression test for PR 10000 updated lifting tests for new variable name convention svn: r12994 --- collects/tests/macro-debugger/gentests.ss | 32 +++--- collects/tests/macro-debugger/tests/policy.ss | 8 +- .../tests/macro-debugger/tests/regression.ss | 23 +++- .../macro-debugger/tests/syntax-macros.ss | 105 +++++++++--------- 4 files changed, 97 insertions(+), 71 deletions(-) diff --git a/collects/tests/macro-debugger/gentests.ss b/collects/tests/macro-debugger/gentests.ss index b1b99fd40b..ca2254d488 100644 --- a/collects/tests/macro-debugger/gentests.ss +++ b/collects/tests/macro-debugger/gentests.ss @@ -101,15 +101,15 @@ (define (check-steps expected actual) (check-pred list? actual) (check-pred reduction-sequence? actual) - (compare-step-sequences expected actual)) + (compare-step-sequences actual expected)) (define (reduction-sequence? rs) (andmap protostep? rs)) -(define (compare-step-sequences expected actual) +(define (compare-step-sequences actual expected) (cond [(and (pair? expected) (pair? actual)) - (begin (compare-steps (car expected) (car actual)) - (compare-step-sequences (cdr expected) (cdr actual)))] + (begin (compare-steps (car actual) (car expected)) + (compare-step-sequences (cdr actual) (cdr expected)))] [(pair? expected) (fail (format "missing expected steps:\n~s" expected))] [(pair? actual) @@ -121,7 +121,7 @@ (stx->datum (step-term2 step)))))))] [else 'ok])) -(define (compare-steps expected actual) +(define (compare-steps actual expected) (cond [(eq? expected 'error) (check-pred misstep? actual)] [else @@ -140,14 +140,16 @@ e-local "Context frame")))])) -(define-binary-check (check-equal-syntax? a b) - (equal-syntax? a b)) +(define-binary-check (check-equal-syntax? a e) + (equal-syntax? a e)) -(define (equal-syntax? a b) - (cond [(and (pair? a) (pair? b)) - (and (equal-syntax? (car a) (car b)) - (equal-syntax? (cdr a) (cdr b)))] - [(and (symbol? a) (symbol? b)) - (equal? (string->symbol (symbol->string a)) - b)] - [else (equal? a b)])) +(define (equal-syntax? a e) + (cond [(and (pair? a) (pair? e)) + (and (equal-syntax? (car a) (car e)) + (equal-syntax? (cdr a) (cdr e)))] + [(and (symbol? a) (symbol? e)) + (equal? (symbol->string a) + (symbol->string e))] + [(and (symbol? a) (regexp? e)) + (regexp-match? e (symbol->string a))] + [else (equal? a e)])) diff --git a/collects/tests/macro-debugger/tests/policy.ss b/collects/tests/macro-debugger/tests/policy.ss index 0e1d637edf..dec45f3169 100644 --- a/collects/tests/macro-debugger/tests/policy.ss +++ b/collects/tests/macro-debugger/tests/policy.ss @@ -10,11 +10,13 @@ (eval '(require (prefix-in base: scheme/base)) ns) (eval '(require (prefix-in scheme: scheme)) ns) +(define (make-test-id sym) + (parameterize ((current-namespace ns)) + (namespace-symbol->identifier sym))) + (define-syntax-rule (test-policy policy name show?) (test-case (format "~s" 'name) - (check-eq? (policy - (parameterize ((current-namespace ns)) - (namespace-symbol->identifier 'name))) + (check-eq? (policy (make-test-id 'name)) show?))) (define-syntax-rule (test-standard name show?) (test-policy standard-policy name show?)) diff --git a/collects/tests/macro-debugger/tests/regression.ss b/collects/tests/macro-debugger/tests/regression.ss index 258e34fd55..6758f6a87a 100644 --- a/collects/tests/macro-debugger/tests/regression.ss +++ b/collects/tests/macro-debugger/tests/regression.ss @@ -167,4 +167,25 @@ (add1 (g 2))))))]) (check-pred list? rs) (check-true (ormap misstep? rs)))) - )) + + ;; Added 1/3/2008 + ;; Based on PR 10000 + (test-case "eval within module expansion" + (let ([freshname (gensym)]) + (eval `(module ,freshname scheme + (provide meval) + (define-syntax (meval stx) + (syntax-case stx () + [(meval e) + (parameterize ((current-namespace (make-base-namespace))) + (eval `(define one '1)) + (let ([v (eval `(+ 1 ,#'e))]) + #`(quote #,v)))])))) + (eval `(require ',freshname)) + (check-pred deriv? + (trace `(meval (+ 1 2)))) + (check-pred deriv? + (trace `(module m mzscheme + (require ',freshname) + (meval (+ 1 2))))))) + )) diff --git a/collects/tests/macro-debugger/tests/syntax-macros.ss b/collects/tests/macro-debugger/tests/syntax-macros.ss index 0119a32d0a..3df5d68234 100644 --- a/collects/tests/macro-debugger/tests/syntax-macros.ss +++ b/collects/tests/macro-debugger/tests/syntax-macros.ss @@ -44,76 +44,77 @@ (test "lift" (lift 'a) - [#:steps (local-lift lifted (lift 'a)) - (macro (#%expression lifted)) - (tag-top (#%expression (#%top . lifted))) - (capture-lifts (begin (define-values (lifted) 'a) - (#%expression (#%top . lifted))))] + [#:steps (local-lift #rx"^lifted" (lift 'a)) + (macro (#%expression #rx"^lifted")) + (tag-top (#%expression (#%top . #rx"^lifted"))) + (capture-lifts (begin (define-values (#rx"^lifted") 'a) + (#%expression + (#%top . #rx"^lifted"))))] #:no-hidden-steps) (test "lift with id" (lift (id 'a)) - [#:steps (local-lift lifted (lift (id 'a))) - (macro (#%expression lifted)) - (tag-top (#%expression (#%top . lifted))) - (capture-lifts (begin (define-values (lifted) (id 'a)) - (#%expression (#%top . lifted)))) - (macro (begin (define-values (lifted) 'a) - (#%expression (#%top . lifted))))] + [#:steps (local-lift #rx"^lifted" (lift (id 'a))) + (macro (#%expression #rx"^lifted")) + (tag-top (#%expression (#%top . #rx"^lifted"))) + (capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) + (#%expression (#%top . #rx"^lifted")))) + (macro (begin (define-values (#rx"^lifted") 'a) + (#%expression (#%top . #rx"^lifted"))))] #:no-hidden-steps) (test "lift with Tid" (lift (Tid 'a)) - [#:steps (local-lift lifted (lift (Tid 'a))) - (macro (#%expression lifted)) - (tag-top (#%expression (#%top . lifted))) - (capture-lifts (begin (define-values (lifted) (Tid 'a)) - (#%expression (#%top . lifted)))) - (macro (begin (define-values (lifted) 'a) - (#%expression (#%top . lifted))))] + [#:steps (local-lift #rx"^lifted" (lift (Tid 'a))) + (macro (#%expression #rx"^lifted")) + (tag-top (#%expression (#%top . #rx"^lifted"))) + (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) + (#%expression (#%top . #rx"^lifted")))) + (macro (begin (define-values (#rx"^lifted") 'a) + (#%expression (#%top . #rx"^lifted"))))] ;; Don't show lifts, but do find (Tid 'a), show in orig ctx [#:hidden-steps (macro (lift 'a))]) (test "Tlift" (Tlift 'a) - [#:steps (local-lift lifted (Tlift 'a)) - (macro (#%expression lifted)) - (tag-top (#%expression (#%top . lifted))) - (capture-lifts (begin (define-values (lifted) 'a) - (#%expression (#%top . lifted))))] - [#:hidden-steps (local-lift lifted (Tlift 'a)) - (macro (#%expression lifted)) - (capture-lifts (begin (define-values (lifted) 'a) - (#%expression lifted)))]) + [#:steps (local-lift #rx"^lifted" (Tlift 'a)) + (macro (#%expression #rx"^lifted")) + (tag-top (#%expression (#%top . #rx"^lifted"))) + (capture-lifts (begin (define-values (#rx"^lifted") 'a) + (#%expression (#%top . #rx"^lifted"))))] + [#:hidden-steps (local-lift #rx"^lifted" (Tlift 'a)) + (macro (#%expression #rx"^lifted")) + (capture-lifts (begin (define-values (#rx"^lifted") 'a) + (#%expression #rx"^lifted")))]) (test "Tlift with id" (Tlift (id 'a)) - [#:steps (local-lift lifted (Tlift (id 'a))) - (macro (#%expression lifted)) - (tag-top (#%expression (#%top . lifted))) - (capture-lifts (begin (define-values (lifted) (id 'a)) - (#%expression (#%top . lifted)))) - (macro (begin (define-values (lifted) 'a) - (#%expression (#%top . lifted))))] - [#:hidden-steps (local-lift lifted (Tlift (id 'a))) - (macro (#%expression lifted)) - (capture-lifts (begin (define-values (lifted) (id 'a)) - (#%expression lifted)))]) + [#:steps (local-lift #rx"^lifted" (Tlift (id 'a))) + (macro (#%expression #rx"^lifted")) + (tag-top (#%expression (#%top . #rx"^lifted"))) + (capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) + (#%expression (#%top . #rx"^lifted")))) + (macro (begin (define-values (#rx"^lifted") 'a) + (#%expression (#%top . #rx"^lifted"))))] + [#:hidden-steps (local-lift #rx"^lifted" (Tlift (id 'a))) + (macro (#%expression #rx"^lifted")) + (capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) + (#%expression #rx"^lifted")))]) (test "Tlift with Tid" (Tlift (Tid 'a)) - [#:steps (local-lift lifted (Tlift (Tid 'a))) - (macro (#%expression lifted)) - (tag-top (#%expression (#%top . lifted))) - (capture-lifts (begin (define-values (lifted) (Tid 'a)) - (#%expression (#%top . lifted)))) - (macro (begin (define-values (lifted) 'a) - (#%expression (#%top . lifted))))] - [#:steps (local-lift lifted (Tlift (Tid 'a))) - (macro (#%expression lifted)) - (capture-lifts (begin (define-values (lifted) (Tid 'a)) - (#%expression lifted))) - (macro (begin (define-values (lifted) 'a) - (#%expression lifted)))]) + [#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a))) + (macro (#%expression #rx"^lifted")) + (tag-top (#%expression (#%top . #rx"^lifted"))) + (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) + (#%expression (#%top . #rx"^lifted")))) + (macro (begin (define-values (#rx"^lifted") 'a) + (#%expression (#%top . #rx"^lifted"))))] + [#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a))) + (macro (#%expression #rx"^lifted")) + (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) + (#%expression #rx"^lifted"))) + (macro (begin (define-values (#rx"^lifted") 'a) + (#%expression #rx"^lifted")))]) [#:suite "set! macros" (test "set! (macro)" From 7da5ee60297d6aae9ead6983692fc3f7ff27a40c Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Sat, 3 Jan 2009 20:48:19 +0000 Subject: [PATCH 12/49] Fixed check-reduction-relation's handling of cases with `where' and `side-condition' clauses. svn: r12995 --- collects/redex/private/reduction-semantics.ss | 24 +++++------ collects/redex/private/rg-test.ss | 40 ++++++++++++++----- collects/redex/private/tl-test.ss | 6 ++- 3 files changed, 44 insertions(+), 26 deletions(-) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index db9c0c8562..653464e38c 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -510,16 +510,13 @@ p)]))))) (define (do-leaf stx orig-name lang name-table from to extras lang-id) - (let ([lang-nts (language-id-nts lang-id orig-name)]) + (let* ([lang-nts (language-id-nts lang-id orig-name)] + [rw-sc (λ (pat) (rewrite-side-conditions/check-errs lang-nts orig-name #t pat))]) (let-values ([(name fresh-vars side-conditions/withs) (process-extras stx orig-name name-table extras)]) (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t from)]) - (with-syntax ([side-conditions-rewritten - (rewrite-side-conditions/check-errs - lang-nts - orig-name - #t - from)] - [to to #;#`,(begin (printf "~s\n" #,name) (term #,to))] + (with-syntax ([side-conditions-rewritten (rw-sc from)] + [lhs-w/extras (rw-sc #`(side-condition #,from #,(bind-withs side-conditions/withs #'#t)))] + [to to] [name name] [lang lang] [(names ...) names] @@ -550,14 +547,15 @@ #`(do-leaf-match name `side-conditions-rewritten + `lhs-w/extras (λ (main bindings) ;; nested term-let's so that the bindings for the variables ;; show up in the `fresh' side-conditions, the bindings for the variables ;; show up in the withs, and the withs show up in the 'fresh' side-conditions (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) - (term-let (fresh-var-clauses ...) - #,(bind-withs side-conditions/withs - #'(make-successful (term to)))))))))))) + (term-let (fresh-var-clauses ...) + #,(bind-withs side-conditions/withs + #'(make-successful (term to)))))))))))) ;; the withs and side-conditions come in backwards order (define (bind-withs stx body) @@ -756,7 +754,7 @@ (rewrite-proc-name child-make-proc) (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from))) -(define (do-leaf-match name pat proc) +(define (do-leaf-match name pat w/extras proc) (make-rewrite-proc (λ (lang) (let ([cp (compile-pattern lang pat #t)]) @@ -771,7 +769,7 @@ other-matches) other-matches))))) name - pat)) + w/extras)) (define-syntax (test-match stx) (syntax-case stx () diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 299eb3aa06..b556163db9 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -540,16 +540,17 @@ (define-language L (e (+ e ...) number) (E (+ number ... E* e ...)) - (E* hole E*)) - (define R - (reduction-relation - L - (==> (+ number ...) whatever) - (--> (side-condition number (even? (term number))) whatever) - with - [(--> (in-hole E a) whatever) - (==> a b)])) - (let ([generated null]) + (E* hole E*) + (n 4)) + + (let ([generated null] + [R (reduction-relation + L + (==> (+ number ...) whatever) + (--> (side-condition number (even? (term number))) whatever) + with + [(--> (in-hole E a) whatever) + (==> a b)])]) (test (begin (check-reduction-relation R (λ (term) (set! generated (cons term generated))) @@ -558,6 +559,7 @@ #:attempts 1) generated) (reverse '((+ (+)) 0)))) + (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))]) (test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t) (test (current-error-port-output @@ -565,7 +567,23 @@ "checking name failed after 1 attempts:\n1\n") (test (current-error-port-output (λ () (check-reduction-relation S (curry eq? 1)))) - "checking unnamed failed after 1 attempts:\n3\n"))) + "checking unnamed failed after 1 attempts:\n3\n")) + + (let ([T (reduction-relation + L + (==> number number + (where num number) + (side-condition (eq? (term num) 4)) + (where numb num) + (side-condition (eq? (term numb) 4))) + with + [(--> (9 a) b) + (==> a b)])]) + (test (check-reduction-relation + T (curry equal? '(9 4)) + #:attempts 1 + #:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x))))) + #t))) ; check-metafunction (let () diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index db8b0ea187..b26f028fc9 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -1156,7 +1156,9 @@ [else #f])) ; test shortcut in terms of shortcut - (test (rewrite-proc-lhs (third (reduction-relation-make-procs r))) - '((5 2) 1))) + (test (match (rewrite-proc-lhs (third (reduction-relation-make-procs r))) + [`(((side-condition 5 ,(? procedure?)) 2) 1) #t] + [else #f]) + #t)) (print-tests-passed 'tl-test.ss)) From 2a61276917f4bc91baf86aea52fd1b421a49d748 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 3 Jan 2009 23:55:08 +0000 Subject: [PATCH 13/49] set misc properties svn: r12996 --- collects/2htdp/private/syn-aux.ss | 2 +- collects/2htdp/universe.ss | 0 2 files changed, 1 insertion(+), 1 deletion(-) mode change 100755 => 100644 collects/2htdp/universe.ss diff --git a/collects/2htdp/private/syn-aux.ss b/collects/2htdp/private/syn-aux.ss index a44a2af08d..0c49229bec 100644 --- a/collects/2htdp/private/syn-aux.ss +++ b/collects/2htdp/private/syn-aux.ss @@ -40,4 +40,4 @@ (lambda (p) (syntax-case p () [(b) #'(coerce> tag b)] - [_ (err tag p)]))) \ No newline at end of file + [_ (err tag p)]))) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss old mode 100755 new mode 100644 From a0a386e71f4a328ec92e2ad5a2cd405eac625d12 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 4 Jan 2009 08:50:13 +0000 Subject: [PATCH 14/49] Welcome to a new PLT day. svn: r12998 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 8803daa287..6388e25ae4 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "3jan2009") +#lang scheme/base (provide stamp) (define stamp "4jan2009") From e371bd8f4aff334cd13ec827dc1038c7d7976c78 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 4 Jan 2009 13:59:00 +0000 Subject: [PATCH 15/49] completed Matthias's aborted commit svn: r12999 --- collects/teachpack/2htdp/scribblings/2htdp.scrbl | 10 ++++++++++ collects/teachpack/2htdp/scribblings/universe.scrbl | 6 +++--- collects/teachpack/teachpack.scrbl | 3 ++- collects/tests/drscheme/teachpack.ss | 11 +++++++---- 4 files changed, 22 insertions(+), 8 deletions(-) create mode 100644 collects/teachpack/2htdp/scribblings/2htdp.scrbl diff --git a/collects/teachpack/2htdp/scribblings/2htdp.scrbl b/collects/teachpack/2htdp/scribblings/2htdp.scrbl new file mode 100644 index 0000000000..9f1a950ef6 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/2htdp.scrbl @@ -0,0 +1,10 @@ +#lang scribble/doc + +@(require scribble/manual + (for-label scheme)) + +@title[#:style '(toc) #:tag "2htdp"]{HtDP/2e Teachpacks} + +@local-table-of-contents[] + +@include-section["universe.scrbl"] diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index c95ddeabc8..e6485da455 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -1,9 +1,9 @@ #lang scribble/doc @(require scribble/manual "shared.ss" - (for-label scheme ; lang/htdp-beginner + (for-label scheme (only-in lang/htdp-beginner check-expect) - "../universe.ss" + teachpack/2htdp/universe teachpack/htdp/image)) @(require scribble/struct) @@ -47,7 +47,7 @@ The purpose of this documentation is to give experienced Schemers and HtDP have a series of projects available as a small booklet on @link["http://world.cs.brown.edu/"]{How to Design Worlds}. -@declare-exporting["../universe.ss" #:use-sources (teachpack/htdp/image)] +@declare-exporting[teachpack/2htdp/universe #:use-sources (teachpack/htdp/image)] @; ----------------------------------------------------------------------------- diff --git a/collects/teachpack/teachpack.scrbl b/collects/teachpack/teachpack.scrbl index 4d288e3dea..409cd70f8c 100644 --- a/collects/teachpack/teachpack.scrbl +++ b/collects/teachpack/teachpack.scrbl @@ -23,7 +23,8 @@ This chapter covers the teachpacks for @italic{How to Design Programs} @table-of-contents[] - @include-section["htdp/scribblings/htdp.scrbl"] @include-section["htdc/scribblings/htdc.scrbl"] + +@include-section["2htdp/scribblings/2htdp.scrbl"] diff --git a/collects/tests/drscheme/teachpack.ss b/collects/tests/drscheme/teachpack.ss index c3de7a7deb..f78ebed614 100644 --- a/collects/tests/drscheme/teachpack.ss +++ b/collects/tests/drscheme/teachpack.ss @@ -213,13 +213,16 @@ (printf "FAILED built in teachpack test: ~a~n" (path->string teachpack)) (printf " got: ~s~n expected: ~s~n" got expected)))))))] [test-teachpacks - (lambda (dir) - (for-each (test-teachpack dir) - (directory-list dir)))] + (lambda (paths) + (for-each (lambda (dir) + (for-each (test-teachpack dir) + (directory-list dir))) + paths))] [teachpack-dir (normalize-path (collection-path "teachpack"))]) (set-language-level! '("How to Design Programs" "Advanced Student")) (do-execute drs-frame) - (test-teachpacks (build-path teachpack-dir "htdp")))) + (test-teachpacks (list (build-path teachpack-dir "2htdp") + (build-path teachpack-dir "htdp"))))) (define (find-leftmost-choice frame) (let loop ([p frame]) From 2527029adb9532c9793b56b63d81e3766f5d1bf1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Jan 2009 14:08:13 +0000 Subject: [PATCH 16/49] doc tweaks svn: r13000 --- collects/scribblings/guide/dialects.scrbl | 8 ++++---- collects/scribblings/reference/bytes.scrbl | 17 +++++++++-------- collects/scribblings/reference/class.scrbl | 4 ++++ 3 files changed, 17 insertions(+), 12 deletions(-) diff --git a/collects/scribblings/guide/dialects.scrbl b/collects/scribblings/guide/dialects.scrbl index 41786daaf7..a37420e1ff 100644 --- a/collects/scribblings/guide/dialects.scrbl +++ b/collects/scribblings/guide/dialects.scrbl @@ -45,9 +45,9 @@ does not define a module system. Typical single-file @|r5rs| programs can be converted to PLT Scheme programs by prefixing them with @scheme[#, @hash-lang[] #, @schememodname[r5rs]], but other Scheme systems do not recognize @scheme[#, @hash-lang[] #, -@schememodname[r5rs]] (which is not part of the @|r5rs| standard). The -@exec{plt-r5rs} executable more directly conforms to the @|r5rs| -standard. +@schememodname[r5rs]]. The @exec{plt-r5rs} executable (see +@secref[#:doc '(lib "r5rs/r5rs.scrbl") "plt-r5rs"]) more directly +conforms to the @|r5rs| standard. Aside from the module system, the syntactic forms and functions of @|r5rs| and PLT Scheme differ. Only simple @|r5rs| become PLT Scheme @@ -118,7 +118,7 @@ including the following: ] Each of these languages is used by starting module with the language -name after @hash-lang[]. For example, this source of this very +name after @hash-lang[]. For example, this source of this document starts with @scheme[#, @hash-lang[] scribble/doc]. PLT Scheme users can define their own languages. A language name maps diff --git a/collects/scribblings/reference/bytes.scrbl b/collects/scribblings/reference/bytes.scrbl index a8273f9e88..8e3838c7c8 100644 --- a/collects/scribblings/reference/bytes.scrbl +++ b/collects/scribblings/reference/bytes.scrbl @@ -405,14 +405,15 @@ Windows and Mac OS X. @filepath{iconv.dll} is included with @filepath{libmzsch@italic{VERS}.dll}.} The set of available encodings and combinations varies by platform, -depending on the @exec{iconv} library that is installed. Under -Windows, @filepath{iconv.dll} or @filepath{libiconv.dll} must be in the same -directory as @filepath{libmzsch@italic{VERS}.dll} (where @italic{VERS} is -a version number), in the user's path, in the system directory, or in -the current executable's directory at run time, and the DLL must -either supply @tt{_errno} or link to @filepath{msvcrt.dll} for -@tt{_errno}; otherwise, only the guaranteed combinations are -available.} +depending on the @exec{iconv} library that is installed; the +@scheme[from-name] and @scheme[to-name] arguments are passed on to +@tt{iconv_open}. Under Windows, @filepath{iconv.dll} or +@filepath{libiconv.dll} must be in the same directory as +@filepath{libmzsch@italic{VERS}.dll} (where @italic{VERS} is a version +number), in the user's path, in the system directory, or in the +current executable's directory at run time, and the DLL must either +supply @tt{_errno} or link to @filepath{msvcrt.dll} for @tt{_errno}; +otherwise, only the guaranteed combinations are available.} @defproc[(bytes-close-converter [converter bytes-converter?]) void]{ diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index adbb77410c..4b066c366f 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -158,6 +158,8 @@ interface is not an object (i.e., there are no ``meta-classes'' or @section[#:tag "createinterface"]{Creating Interfaces} +@guideintro["classes"]{classes, objects, and interfaces} + @defform[(interface (super-interface-expr ...) id ...)]{ Produces an interface. The @scheme[id]s must be mutually distinct. @@ -207,6 +209,8 @@ structure type property's guard, if any).} @section[#:tag "createclass"]{Creating Classes} +@guideintro["classes"]{classes and objects} + @defthing[object% class?]{ A built-in class that has no methods fields, implements only its own From 8a2753efb8fb4df490feec8d52c570cba17d2bdd Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 4 Jan 2009 15:34:50 +0000 Subject: [PATCH 17/49] 2008 -> 2009 svn: r13001 --- collects/compiler/compiler-unit.ss | 2 +- collects/compiler/main.ss | 2 +- collects/mzlib/md5.ss | 2 +- collects/scribblings/main/license.scrbl | 8 ++++---- collects/sgl/sgl.ss | 2 +- collects/srfi/43/vector-lib.ss | 2 +- collects/srfi/63/63.ss | 2 +- collects/swindle/readme.txt | 2 +- man/man1/tex2page.1 | 2 +- src/mred/mred.cxx | 2 +- src/mred/mred.h | 2 +- src/mred/mredmac.cxx | 2 +- src/mred/mredmsw.cxx | 2 +- src/mred/mredx.cxx | 2 +- src/mred/mrmain.cxx | 2 +- src/mred/wxme/wx_cgrec.cxx | 2 +- src/mred/wxme/wx_keym.cxx | 2 +- src/mred/wxme/wx_madm.h | 2 +- src/mred/wxme/wx_mbuf.cxx | 2 +- src/mred/wxme/wx_medad.cxx | 2 +- src/mred/wxme/wx_media.cxx | 2 +- src/mred/wxme/wx_mline.cxx | 2 +- src/mred/wxme/wx_mpbrd.cxx | 2 +- src/mred/wxme/wx_mpriv.cxx | 2 +- src/mred/wxme/wx_msnip.cxx | 2 +- src/mred/wxme/wx_snip.cxx | 2 +- src/mred/wxme/wx_style.cxx | 2 +- src/mzscheme/dynsrc/mzdyn.c | 2 +- src/mzscheme/gc2/compact.c | 2 +- src/mzscheme/gc2/copy.c | 2 +- src/mzscheme/include/escheme.h | 2 +- src/mzscheme/include/scheme.h | 2 +- src/mzscheme/main.c | 2 +- src/mzscheme/sgc/sgc.c | 2 +- src/mzscheme/src/bignum.c | 2 +- src/mzscheme/src/bool.c | 2 +- src/mzscheme/src/builtin.c | 2 +- src/mzscheme/src/char.c | 2 +- src/mzscheme/src/complex.c | 2 +- src/mzscheme/src/dynext.c | 2 +- src/mzscheme/src/env.c | 2 +- src/mzscheme/src/error.c | 2 +- src/mzscheme/src/eval.c | 2 +- src/mzscheme/src/file.c | 2 +- src/mzscheme/src/fun.c | 2 +- src/mzscheme/src/hash.c | 2 +- src/mzscheme/src/jit.c | 2 +- src/mzscheme/src/list.c | 2 +- src/mzscheme/src/module.c | 2 +- src/mzscheme/src/mzsj86.c | 2 +- src/mzscheme/src/network.c | 2 +- src/mzscheme/src/numarith.c | 2 +- src/mzscheme/src/number.c | 2 +- src/mzscheme/src/numcomp.c | 2 +- src/mzscheme/src/nummacs.h | 2 +- src/mzscheme/src/numstr.c | 2 +- src/mzscheme/src/port.c | 2 +- src/mzscheme/src/portfun.c | 2 +- src/mzscheme/src/print.c | 2 +- src/mzscheme/src/rational.c | 2 +- src/mzscheme/src/read.c | 2 +- src/mzscheme/src/regexp.c | 2 +- src/mzscheme/src/salloc.c | 2 +- src/mzscheme/src/schemef.h | 2 +- src/mzscheme/src/schemex.h | 2 +- src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/sema.c | 2 +- src/mzscheme/src/setjmpup.c | 2 +- src/mzscheme/src/string.c | 4 ++-- src/mzscheme/src/struct.c | 2 +- src/mzscheme/src/stxobj.c | 2 +- src/mzscheme/src/symbol.c | 2 +- src/mzscheme/src/syntax.c | 2 +- src/mzscheme/src/thread.c | 2 +- src/mzscheme/src/type.c | 2 +- src/mzscheme/src/vector.c | 2 +- src/worksp/mred/mred.rc | 2 +- src/worksp/mzcom/mzcom.rc | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 2 +- src/worksp/starters/start.rc | 2 +- src/wxcommon/FontDirectory.cxx | 2 +- src/wxcommon/FontDirectory.h | 2 +- src/wxcommon/PSDC.cxx | 2 +- src/wxcommon/PSDC.h | 2 +- src/wxcommon/wb_hash.cxx | 2 +- src/wxcommon/wb_list.cxx | 2 +- src/wxcommon/wxGC.cxx | 2 +- src/wxcommon/wxGC.h | 2 +- src/wxcommon/wx_hash.h | 2 +- src/wxcommon/wx_list.h | 2 +- src/wxmac/include/base/common.h | 2 +- src/wxmac/include/base/wb_buttn.h | 2 +- src/wxmac/include/base/wb_canvs.h | 2 +- src/wxmac/include/base/wb_check.h | 2 +- src/wxmac/include/base/wb_choic.h | 2 +- src/wxmac/include/base/wb_dc.h | 2 +- src/wxmac/include/base/wb_dccan.h | 2 +- src/wxmac/include/base/wb_dcmem.h | 2 +- src/wxmac/include/base/wb_dialg.h | 2 +- src/wxmac/include/base/wb_frame.h | 2 +- src/wxmac/include/base/wb_gauge.h | 2 +- src/wxmac/include/base/wb_gdi.h | 2 +- src/wxmac/include/base/wb_item.h | 2 +- src/wxmac/include/base/wb_lbox.h | 2 +- src/wxmac/include/base/wb_main.h | 2 +- src/wxmac/include/base/wb_menu.h | 2 +- src/wxmac/include/base/wb_messg.h | 2 +- src/wxmac/include/base/wb_mnuit.h | 2 +- src/wxmac/include/base/wb_panel.h | 2 +- src/wxmac/include/base/wb_rbox.h | 2 +- src/wxmac/include/base/wb_slidr.h | 2 +- src/wxmac/include/base/wb_timer.h | 2 +- src/wxmac/include/base/wb_win.h | 2 +- src/wxmac/include/base/wx.h | 2 +- src/wxmac/include/base/wx_clipb.h | 2 +- src/wxmac/include/base/wx_obj.h | 2 +- src/wxmac/include/base/wx_setup.h | 2 +- src/wxmac/include/base/wx_stdev.h | 2 +- src/wxmac/include/base/wx_sysev.h | 2 +- src/wxmac/include/base/wx_types.h | 2 +- src/wxmac/include/base/wx_utils.h | 2 +- src/wxmac/include/mac/wxBorder.h | 2 +- src/wxmac/include/mac/wxBorderArea.h | 2 +- src/wxmac/include/mac/wxButtonBorder.h | 2 +- src/wxmac/include/mac/wxDirection.h | 2 +- src/wxmac/include/mac/wxLabelArea.h | 2 +- src/wxmac/include/mac/wxMacDC.h | 2 +- src/wxmac/include/mac/wxMargin.h | 2 +- src/wxmac/include/mac/wxRectBorder.h | 2 +- src/wxmac/include/mac/wxScroll.h | 2 +- src/wxmac/include/mac/wxScrollArea.h | 2 +- src/wxmac/include/mac/wxScrollData.h | 2 +- src/wxmac/include/mac/wx_area.h | 2 +- src/wxmac/include/mac/wx_buttn.h | 2 +- src/wxmac/include/mac/wx_canvs.h | 2 +- src/wxmac/include/mac/wx_check.h | 2 +- src/wxmac/include/mac/wx_choic.h | 2 +- src/wxmac/include/mac/wx_dc.h | 2 +- src/wxmac/include/mac/wx_dccan.h | 2 +- src/wxmac/include/mac/wx_dcmem.h | 2 +- src/wxmac/include/mac/wx_dcpr.h | 2 +- src/wxmac/include/mac/wx_dialg.h | 2 +- src/wxmac/include/mac/wx_frame.h | 2 +- src/wxmac/include/mac/wx_gauge.h | 2 +- src/wxmac/include/mac/wx_gbox.h | 2 +- src/wxmac/include/mac/wx_gdi.h | 2 +- src/wxmac/include/mac/wx_item.h | 2 +- src/wxmac/include/mac/wx_lbox.h | 2 +- src/wxmac/include/mac/wx_mac_utils.h | 2 +- src/wxmac/include/mac/wx_main.h | 2 +- src/wxmac/include/mac/wx_menu.h | 2 +- src/wxmac/include/mac/wx_messg.h | 2 +- src/wxmac/include/mac/wx_mnuit.h | 2 +- src/wxmac/include/mac/wx_panel.h | 2 +- src/wxmac/include/mac/wx_print.h | 2 +- src/wxmac/include/mac/wx_rbox.h | 2 +- src/wxmac/include/mac/wx_rbut.h | 2 +- src/wxmac/include/mac/wx_sbar.h | 2 +- src/wxmac/include/mac/wx_screen.h | 2 +- src/wxmac/include/mac/wx_slidr.h | 2 +- src/wxmac/include/mac/wx_tabc.h | 2 +- src/wxmac/include/mac/wx_timer.h | 2 +- src/wxmac/include/mac/wx_win.h | 2 +- src/wxmac/include/mac/wximgfil.h | 2 +- src/wxmac/src/base/wb_canvs.cc | 2 +- src/wxmac/src/base/wb_dc.cc | 2 +- src/wxmac/src/base/wb_dialg.cc | 2 +- src/wxmac/src/base/wb_frame.cc | 2 +- src/wxmac/src/base/wb_gdi.cc | 2 +- src/wxmac/src/base/wb_item.cc | 2 +- src/wxmac/src/base/wb_main.cc | 2 +- src/wxmac/src/base/wb_obj.cc | 2 +- src/wxmac/src/base/wb_panel.cc | 2 +- src/wxmac/src/base/wb_stdev.cc | 2 +- src/wxmac/src/base/wb_sysev.cc | 2 +- src/wxmac/src/base/wb_timer.cc | 2 +- src/wxmac/src/base/wb_types.cc | 2 +- src/wxmac/src/base/wb_utils.cc | 2 +- src/wxmac/src/base/wb_win.cc | 2 +- src/wxmac/src/base/xfspline.cc | 2 +- src/wxmac/src/mac/wxBorder.cc | 2 +- src/wxmac/src/mac/wxBorderArea.cc | 2 +- src/wxmac/src/mac/wxButtonBorder.cc | 2 +- src/wxmac/src/mac/wxLabelArea.cc | 2 +- src/wxmac/src/mac/wxMacDC.cc | 2 +- src/wxmac/src/mac/wxMargin.cc | 2 +- src/wxmac/src/mac/wxRectBorder.cc | 2 +- src/wxmac/src/mac/wxScroll.cc | 2 +- src/wxmac/src/mac/wxScrollArea.cc | 2 +- src/wxmac/src/mac/wxScrollData.cc | 2 +- src/wxmac/src/mac/wx_app.cc | 2 +- src/wxmac/src/mac/wx_area.cc | 2 +- src/wxmac/src/mac/wx_buttn.cc | 2 +- src/wxmac/src/mac/wx_canvs.cc | 2 +- src/wxmac/src/mac/wx_check.cc | 2 +- src/wxmac/src/mac/wx_choic.cc | 2 +- src/wxmac/src/mac/wx_clipb.cc | 2 +- src/wxmac/src/mac/wx_dc.cc | 2 +- src/wxmac/src/mac/wx_dccan1.cc | 2 +- src/wxmac/src/mac/wx_dccan2.cc | 2 +- src/wxmac/src/mac/wx_dccan3.cc | 2 +- src/wxmac/src/mac/wx_dcmem.cc | 2 +- src/wxmac/src/mac/wx_dialg.cc | 2 +- src/wxmac/src/mac/wx_frame.cc | 2 +- src/wxmac/src/mac/wx_gauge.cc | 2 +- src/wxmac/src/mac/wx_gbox.cc | 2 +- src/wxmac/src/mac/wx_gdi.cc | 2 +- src/wxmac/src/mac/wx_item.cc | 2 +- src/wxmac/src/mac/wx_lbox.cc | 2 +- src/wxmac/src/mac/wx_mac_utils.cc | 2 +- src/wxmac/src/mac/wx_main.cc | 2 +- src/wxmac/src/mac/wx_menu.cc | 2 +- src/wxmac/src/mac/wx_messg.cc | 2 +- src/wxmac/src/mac/wx_mnuit.cc | 2 +- src/wxmac/src/mac/wx_panel.cc | 2 +- src/wxmac/src/mac/wx_print.cc | 2 +- src/wxmac/src/mac/wx_rbox.cc | 2 +- src/wxmac/src/mac/wx_rbut.cc | 2 +- src/wxmac/src/mac/wx_sbar.cc | 2 +- src/wxmac/src/mac/wx_screen.cc | 2 +- src/wxmac/src/mac/wx_slidr.cc | 2 +- src/wxmac/src/mac/wx_tabc.cc | 2 +- src/wxmac/src/mac/wx_win.cc | 2 +- src/wxmac/utils/image/src/wx_image.cc | 2 +- src/wxmac/utils/image/src/wx_image.h | 2 +- src/wxmac/utils/image/src/wx_imgx.h | 2 +- src/wxwindow/include/base/common.h | 2 +- src/wxwindow/include/base/wb_buttn.h | 2 +- src/wxwindow/include/base/wb_canvs.h | 2 +- src/wxwindow/include/base/wb_check.h | 2 +- src/wxwindow/include/base/wb_choic.h | 2 +- src/wxwindow/include/base/wb_cmdlg.h | 2 +- src/wxwindow/include/base/wb_dc.h | 2 +- src/wxwindow/include/base/wb_dccan.h | 2 +- src/wxwindow/include/base/wb_dcmem.h | 2 +- src/wxwindow/include/base/wb_dialg.h | 2 +- src/wxwindow/include/base/wb_frame.h | 2 +- src/wxwindow/include/base/wb_gauge.h | 2 +- src/wxwindow/include/base/wb_gdi.h | 2 +- src/wxwindow/include/base/wb_item.h | 2 +- src/wxwindow/include/base/wb_lbox.h | 2 +- src/wxwindow/include/base/wb_main.h | 2 +- src/wxwindow/include/base/wb_menu.h | 2 +- src/wxwindow/include/base/wb_messg.h | 2 +- src/wxwindow/include/base/wb_mf.h | 2 +- src/wxwindow/include/base/wb_mnuit.h | 2 +- src/wxwindow/include/base/wb_panel.h | 2 +- src/wxwindow/include/base/wb_rbox.h | 2 +- src/wxwindow/include/base/wb_slidr.h | 2 +- src/wxwindow/include/base/wb_timer.h | 2 +- src/wxwindow/include/base/wb_win.h | 2 +- src/wxwindow/include/base/wx.h | 2 +- src/wxwindow/include/base/wx_obj.h | 2 +- src/wxwindow/include/base/wx_print.h | 2 +- src/wxwindow/include/base/wx_setup.h | 2 +- src/wxwindow/include/base/wx_stdev.h | 2 +- src/wxwindow/include/base/wx_sysev.h | 2 +- src/wxwindow/include/base/wx_types.h | 2 +- src/wxwindow/include/base/wx_utils.h | 2 +- src/wxwindow/include/msw/wx_buttn.h | 2 +- src/wxwindow/include/msw/wx_canvs.h | 2 +- src/wxwindow/include/msw/wx_check.h | 2 +- src/wxwindow/include/msw/wx_choic.h | 2 +- src/wxwindow/include/msw/wx_clipb.h | 2 +- src/wxwindow/include/msw/wx_cmdlg.h | 2 +- src/wxwindow/include/msw/wx_dc.h | 2 +- src/wxwindow/include/msw/wx_dccan.h | 2 +- src/wxwindow/include/msw/wx_dcmem.h | 2 +- src/wxwindow/include/msw/wx_dialg.h | 2 +- src/wxwindow/include/msw/wx_frame.h | 2 +- src/wxwindow/include/msw/wx_gauge.h | 2 +- src/wxwindow/include/msw/wx_gbox.h | 2 +- src/wxwindow/include/msw/wx_gdi.h | 2 +- src/wxwindow/include/msw/wx_item.h | 2 +- src/wxwindow/include/msw/wx_itemp.h | 2 +- src/wxwindow/include/msw/wx_lbox.h | 2 +- src/wxwindow/include/msw/wx_main.h | 2 +- src/wxwindow/include/msw/wx_menu.h | 2 +- src/wxwindow/include/msw/wx_messg.h | 2 +- src/wxwindow/include/msw/wx_mf.h | 2 +- src/wxwindow/include/msw/wx_mnuit.h | 2 +- src/wxwindow/include/msw/wx_panel.h | 2 +- src/wxwindow/include/msw/wx_privt.h | 2 +- src/wxwindow/include/msw/wx_rbox.h | 2 +- src/wxwindow/include/msw/wx_slidr.h | 2 +- src/wxwindow/include/msw/wx_tabc.h | 2 +- src/wxwindow/include/msw/wx_timer.h | 2 +- src/wxwindow/include/msw/wx_win.h | 2 +- src/wxwindow/include/msw/wximgfil.h | 2 +- src/wxwindow/src/base/wb_canvs.cxx | 2 +- src/wxwindow/src/base/wb_cmdlg.cxx | 2 +- src/wxwindow/src/base/wb_dc.cxx | 2 +- src/wxwindow/src/base/wb_dialg.cxx | 2 +- src/wxwindow/src/base/wb_frame.cxx | 2 +- src/wxwindow/src/base/wb_gdi.cxx | 2 +- src/wxwindow/src/base/wb_item.cxx | 2 +- src/wxwindow/src/base/wb_main.cxx | 2 +- src/wxwindow/src/base/wb_obj.cxx | 2 +- src/wxwindow/src/base/wb_panel.cxx | 2 +- src/wxwindow/src/base/wb_print.cxx | 2 +- src/wxwindow/src/base/wb_stdev.cxx | 2 +- src/wxwindow/src/base/wb_sysev.cxx | 2 +- src/wxwindow/src/base/wb_timer.cxx | 2 +- src/wxwindow/src/base/wb_types.cxx | 2 +- src/wxwindow/src/base/wb_utils.cxx | 2 +- src/wxwindow/src/base/wb_win.cxx | 2 +- src/wxwindow/src/base/xfspline.cxx | 2 +- src/wxwindow/src/msw/wx_buttn.cxx | 2 +- src/wxwindow/src/msw/wx_canvs.cxx | 2 +- src/wxwindow/src/msw/wx_check.cxx | 2 +- src/wxwindow/src/msw/wx_choic.cxx | 2 +- src/wxwindow/src/msw/wx_clipb.cxx | 2 +- src/wxwindow/src/msw/wx_cmdlg.cxx | 2 +- src/wxwindow/src/msw/wx_dc.cxx | 2 +- src/wxwindow/src/msw/wx_dialg.cxx | 2 +- src/wxwindow/src/msw/wx_frame.cxx | 2 +- src/wxwindow/src/msw/wx_gauge.cxx | 2 +- src/wxwindow/src/msw/wx_gbox.cxx | 2 +- src/wxwindow/src/msw/wx_gdi.cxx | 2 +- src/wxwindow/src/msw/wx_item.cxx | 2 +- src/wxwindow/src/msw/wx_lbox.cxx | 2 +- src/wxwindow/src/msw/wx_main.cxx | 2 +- src/wxwindow/src/msw/wx_menu.cxx | 2 +- src/wxwindow/src/msw/wx_messg.cxx | 2 +- src/wxwindow/src/msw/wx_panel.cxx | 2 +- src/wxwindow/src/msw/wx_pdf.cxx | 2 +- src/wxwindow/src/msw/wx_rbox.cxx | 2 +- src/wxwindow/src/msw/wx_slidr.cxx | 2 +- src/wxwindow/src/msw/wx_tabc.cxx | 2 +- src/wxwindow/src/msw/wx_timer.cxx | 2 +- src/wxwindow/src/msw/wx_utils.cxx | 2 +- src/wxwindow/src/msw/wx_win.cxx | 2 +- src/wxxt/src/Application/AppMain.cc | 2 +- src/wxxt/src/Application/AppMain.h | 2 +- src/wxxt/src/Application/GlobalData.cc | 2 +- src/wxxt/src/Application/GlobalData.h | 2 +- src/wxxt/src/DataStructures/Object.cc | 2 +- src/wxxt/src/DataStructures/Object.h | 2 +- src/wxxt/src/DataStructures/TypeTree.cc | 2 +- src/wxxt/src/DataStructures/TypeTree.h | 2 +- src/wxxt/src/DeviceContexts/DC.cc | 2 +- src/wxxt/src/DeviceContexts/DC.h | 2 +- src/wxxt/src/DeviceContexts/MemoryDC.cc | 2 +- src/wxxt/src/DeviceContexts/MemoryDC.h | 2 +- src/wxxt/src/DeviceContexts/WindowDC.cc | 2 +- src/wxxt/src/DeviceContexts/WindowDC.h | 2 +- src/wxxt/src/Dialogs/Dialogs.h | 2 +- src/wxxt/src/Dialogs/FileDialog.cc | 2 +- src/wxxt/src/Dialogs/MessageBox.cc | 2 +- src/wxxt/src/EventHandling/EvtHandler.cc | 2 +- src/wxxt/src/EventHandling/EvtHandler.h | 2 +- src/wxxt/src/EventHandling/wb_stdev.cc | 2 +- src/wxxt/src/EventHandling/wb_sysev.cc | 2 +- src/wxxt/src/EventHandling/wx_stdev.h | 2 +- src/wxxt/src/EventHandling/wx_sysev.h | 2 +- src/wxxt/src/GDI-Classes/Bitmap.cc | 2 +- src/wxxt/src/GDI-Classes/Bitmap.h | 2 +- src/wxxt/src/GDI-Classes/Colour.cc | 2 +- src/wxxt/src/GDI-Classes/Colour.h | 2 +- src/wxxt/src/GDI-Classes/Font.cc | 2 +- src/wxxt/src/GDI-Classes/Font.h | 2 +- src/wxxt/src/GDI-Classes/Pen+Brush.cc | 2 +- src/wxxt/src/GDI-Classes/Pen+Brush.h | 2 +- src/wxxt/src/Misc/Clipboard.cc | 2 +- src/wxxt/src/Misc/Timer.cc | 2 +- src/wxxt/src/Misc/Timer.h | 2 +- src/wxxt/src/Utilities/Application.cc | 2 +- src/wxxt/src/Utilities/Assert.cc | 2 +- src/wxxt/src/Utilities/BusyCursor.cc | 2 +- src/wxxt/src/Utilities/Date+Time.cc | 2 +- src/wxxt/src/Utilities/Directory.cc | 2 +- src/wxxt/src/Utilities/Error.cc | 2 +- src/wxxt/src/Utilities/GDI.cc | 2 +- src/wxxt/src/Utilities/Home.cc | 2 +- src/wxxt/src/Utilities/Misc.cc | 2 +- src/wxxt/src/Utilities/Net.c | 2 +- src/wxxt/src/Utilities/Path.cc | 2 +- src/wxxt/src/Utilities/Resources.cc | 2 +- src/wxxt/src/Utilities/String.cc | 2 +- src/wxxt/src/Utilities/TempFile.cc | 2 +- src/wxxt/src/Utilities/Utilities.h | 2 +- src/wxxt/src/Windows/Button.cc | 2 +- src/wxxt/src/Windows/Button.h | 2 +- src/wxxt/src/Windows/Canvas.cc | 2 +- src/wxxt/src/Windows/Canvas.h | 2 +- src/wxxt/src/Windows/CheckBox.cc | 2 +- src/wxxt/src/Windows/CheckBox.h | 2 +- src/wxxt/src/Windows/Choice.cc | 2 +- src/wxxt/src/Windows/Choice.h | 2 +- src/wxxt/src/Windows/DialogBox.cc | 2 +- src/wxxt/src/Windows/DialogBox.h | 2 +- src/wxxt/src/Windows/Frame.cc | 2 +- src/wxxt/src/Windows/Frame.h | 2 +- src/wxxt/src/Windows/Gauge.cc | 2 +- src/wxxt/src/Windows/Gauge.h | 2 +- src/wxxt/src/Windows/Item.cc | 2 +- src/wxxt/src/Windows/Item.h | 2 +- src/wxxt/src/Windows/Layout.cc | 2 +- src/wxxt/src/Windows/Layout.h | 2 +- src/wxxt/src/Windows/ListBox.cc | 2 +- src/wxxt/src/Windows/ListBox.h | 2 +- src/wxxt/src/Windows/Menu.cc | 2 +- src/wxxt/src/Windows/Menu.h | 2 +- src/wxxt/src/Windows/MenuBar.cc | 2 +- src/wxxt/src/Windows/MenuBar.h | 2 +- src/wxxt/src/Windows/Message.cc | 2 +- src/wxxt/src/Windows/Message.h | 2 +- src/wxxt/src/Windows/Panel.cc | 2 +- src/wxxt/src/Windows/Panel.h | 2 +- src/wxxt/src/Windows/RadioBox.cc | 2 +- src/wxxt/src/Windows/RadioBox.h | 2 +- src/wxxt/src/Windows/Slider.cc | 2 +- src/wxxt/src/Windows/Slider.h | 2 +- src/wxxt/src/Windows/Window.cc | 2 +- src/wxxt/src/Windows/Window.h | 2 +- src/wxxt/src/XWidgets/xwMenu.c | 2 +- src/wxxt/src/XWidgets/xwMenu.h | 2 +- src/wxxt/src/XWidgets/xwMenuP.h | 2 +- src/wxxt/src/XWidgets/xwMultiList.c | 2 +- src/wxxt/src/XWidgets/xwMultiList.h | 2 +- src/wxxt/src/XWidgets/xwMultiListP.h | 2 +- src/wxxt/src/XWidgets/xwScrollText.c | 2 +- src/wxxt/src/XWidgets/xwScrollText.h | 2 +- src/wxxt/src/XWidgets/xwScrollTextP.h | 2 +- src/wxxt/src/XWidgets/xwTools3d.c | 2 +- src/wxxt/src/XWidgets/xwTools3d.h | 2 +- src/wxxt/src/wx.h | 2 +- src/wxxt/src/wxDefines.h | 2 +- src/wxxt/src/wxSetup.h | 2 +- src/wxxt/utils/image/src/wx_image.cc | 2 +- src/wxxt/utils/image/src/wx_image.h | 2 +- src/wxxt/utils/image/src/wx_imgx.h | 2 +- 432 files changed, 438 insertions(+), 438 deletions(-) diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss index 54f3fa06d7..b46c4ae3c3 100644 --- a/collects/compiler/compiler-unit.ss +++ b/collects/compiler/compiler-unit.ss @@ -1,5 +1,5 @@ ;; Main compilation procedures -;; (c) 1997-2008 PLT +;; (c) 1997-2009 PLT ;; The various procedures provided by this library are implemented ;; by dynamically linking to code supplied by the MzLib, dynext, and diff --git a/collects/compiler/main.ss b/collects/compiler/main.ss index 6285ac7d68..3ef078a905 100644 --- a/collects/compiler/main.ss +++ b/collects/compiler/main.ss @@ -401,7 +401,7 @@ (parse-options (current-command-line-arguments))) (when (compiler:option:somewhat-verbose) - (printf "mzc v~a [~a], Copyright (c) 2004-2008 PLT Scheme Inc.\n" + (printf "mzc v~a [~a], Copyright (c) 2004-2009 PLT Scheme Inc.\n" (version) (system-type 'gc))) diff --git a/collects/mzlib/md5.ss b/collects/mzlib/md5.ss index 0cfc0714fe..973d358821 100644 --- a/collects/mzlib/md5.ss +++ b/collects/mzlib/md5.ss @@ -2,7 +2,7 @@ (provide md5) - ;;; Copyright (c) 2005-2008, PLT Scheme Inc. + ;;; Copyright (c) 2005-2009, PLT Scheme Inc. ;;; Copyright (c) 2002, Jens Axel Soegaard ;;; ;;; Permission to copy this software, in whole or in part, to use this diff --git a/collects/scribblings/main/license.scrbl b/collects/scribblings/main/license.scrbl index 8f20d584f0..798e6836b7 100644 --- a/collects/scribblings/main/license.scrbl +++ b/collects/scribblings/main/license.scrbl @@ -28,7 +28,7 @@ for more information. @copyright{ PLT Scheme Copyright (c) 1995-2003 PLT - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. } PLT software includes or extends the following copyrighted material: @@ -36,21 +36,21 @@ PLT software includes or extends the following copyrighted material: @copyright{ DrScheme Copyright (c) 1995-2003 PLT - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. All rights reserved. } @copyright{ MrEd Copyright (c) 1995-2003 PLT - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. All rights reserved. } @copyright{ MzScheme Copyright (c) 1995-2003 PLT - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. All rights reserved. } diff --git a/collects/sgl/sgl.ss b/collects/sgl/sgl.ss index d89496aa27..7e9a1a0ad8 100644 --- a/collects/sgl/sgl.ss +++ b/collects/sgl/sgl.ss @@ -1,6 +1,6 @@ ;; sgl -- An OpenGL extension of MzScheme ;; -;; Copyright (C) 2003-2008 Scott Owens +;; Copyright (C) 2003-2009 Scott Owens ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License diff --git a/collects/srfi/43/vector-lib.ss b/collects/srfi/43/vector-lib.ss index 77cb84529f..6858d61977 100644 --- a/collects/srfi/43/vector-lib.ss +++ b/collects/srfi/43/vector-lib.ss @@ -1,4 +1,4 @@ -;;; Copyright (C) 2005-2008 by Chongkai Zhu. +;;; Copyright (C) 2005-2009 by Chongkai Zhu. (module vector-lib mzscheme diff --git a/collects/srfi/63/63.ss b/collects/srfi/63/63.ss index 79a6e1706d..649e4e9a96 100644 --- a/collects/srfi/63/63.ss +++ b/collects/srfi/63/63.ss @@ -1,6 +1,6 @@ ;; Implementation of SRFI 63 "Homogeneous and Heterogeneous Arrays" for PLT ;; Scheme. -;; Copyright (C) 2007-2008 Chongkai Zhu +;; Copyright (C) 2007-2009 Chongkai Zhu ;; Released under the same terms as the SRFI reference implementation. diff --git a/collects/swindle/readme.txt b/collects/swindle/readme.txt index d90939738e..32d4c5289f 100644 --- a/collects/swindle/readme.txt +++ b/collects/swindle/readme.txt @@ -137,7 +137,7 @@ Swindle environment. ====< Copyright Notice >================================================ -Copyright (C) 1998-2008 Eli Barzilay (eli@barzilay.org) +Copyright (C) 1998-2009 Eli Barzilay (eli@barzilay.org) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/man/man1/tex2page.1 b/man/man1/tex2page.1 index a8a6973a8e..8f9ec1b316 100644 --- a/man/man1/tex2page.1 +++ b/man/man1/tex2page.1 @@ -164,7 +164,7 @@ mpost(1). .SH COPYRIGHT -Copyright 1997-2008 by Dorai Sitaram. +Copyright 1997-2009 by Dorai Sitaram. Permission to distribute and use this work for any purpose is hereby granted provided this copyright notice is included in diff --git a/src/mred/mred.cxx b/src/mred/mred.cxx index 6cc2387a35..d4000c9a13 100644 --- a/src/mred/mred.cxx +++ b/src/mred/mred.cxx @@ -3,7 +3,7 @@ * Purpose: MrEd main file, including a hodge-podge of global stuff * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995-2000, Matthew Flatt */ diff --git a/src/mred/mred.h b/src/mred/mred.h index 8b9f72041b..0b3c686ece 100644 --- a/src/mred/mred.h +++ b/src/mred/mred.h @@ -189,7 +189,7 @@ MRED_EXTERN void mred_set_run_from_cmd_line(MrEd_Run_From_Cmd_Line_Proc); # define mrVERSION_SUFFIX " [cgc]" # endif #endif -#define BANNER "MrEd v" MZSCHEME_VERSION mrVERSION_SUFFIX ", Copyright (c) 2004-2008 PLT Scheme Inc.\n" +#define BANNER "MrEd v" MZSCHEME_VERSION mrVERSION_SUFFIX ", Copyright (c) 2004-2009 PLT Scheme Inc.\n" #ifndef WINDOW_STDIO /* Removing "|| defined(wx_msw)" below uses the Windows console. diff --git a/src/mred/mredmac.cxx b/src/mred/mredmac.cxx index ce42e75dc3..5597a470d9 100644 --- a/src/mred/mredmac.cxx +++ b/src/mred/mredmac.cxx @@ -3,7 +3,7 @@ * Purpose: MrEd MacOS event loop * Author: Matthew Flatt * Created: 1996 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1996, Matthew Flatt */ diff --git a/src/mred/mredmsw.cxx b/src/mred/mredmsw.cxx index a1b19ebe51..a971190aa8 100644 --- a/src/mred/mredmsw.cxx +++ b/src/mred/mredmsw.cxx @@ -3,7 +3,7 @@ * Purpose: MrEd Windows event loop * Author: Matthew Flatt * Created: 1996 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1996, Matthew Flatt */ diff --git a/src/mred/mredx.cxx b/src/mred/mredx.cxx index 32bfe66964..3ec0638008 100644 --- a/src/mred/mredx.cxx +++ b/src/mred/mredx.cxx @@ -3,7 +3,7 @@ * Purpose: MrEd X Windows event loop * Author: Matthew Flatt * Created: 1996 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1996, Matthew Flatt */ diff --git a/src/mred/mrmain.cxx b/src/mred/mrmain.cxx index 878609876c..c7c0f3bd2f 100644 --- a/src/mred/mrmain.cxx +++ b/src/mred/mrmain.cxx @@ -3,7 +3,7 @@ * Purpose: MrEd main file, including a hodge-podge of global stuff * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995-2000, Matthew Flatt */ diff --git a/src/mred/wxme/wx_cgrec.cxx b/src/mred/wxme/wx_cgrec.cxx index ae79b80930..48d660d3cc 100644 --- a/src/mred/wxme/wx_cgrec.cxx +++ b/src/mred/wxme/wx_cgrec.cxx @@ -3,7 +3,7 @@ * Purpose: wxChangeRecord implementations * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_keym.cxx b/src/mred/wxme/wx_keym.cxx index 8446068275..57ff84a8bc 100644 --- a/src/mred/wxme/wx_keym.cxx +++ b/src/mred/wxme/wx_keym.cxx @@ -3,7 +3,7 @@ * Purpose: wxKeymap implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_madm.h b/src/mred/wxme/wx_madm.h index c760ec22a9..03a3a728c2 100644 --- a/src/mred/wxme/wx_madm.h +++ b/src/mred/wxme/wx_madm.h @@ -3,7 +3,7 @@ * Purpose: wxMediaAdmins * Author: Matthew Flatt * Created: 1997 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1997, Matthew Flatt */ diff --git a/src/mred/wxme/wx_mbuf.cxx b/src/mred/wxme/wx_mbuf.cxx index 8f9b3cc985..2f53ed96fe 100644 --- a/src/mred/wxme/wx_mbuf.cxx +++ b/src/mred/wxme/wx_mbuf.cxx @@ -3,7 +3,7 @@ * Purpose: wxMediaBuffer implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995-98, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_medad.cxx b/src/mred/wxme/wx_medad.cxx index 61087116b9..44f61f60f4 100644 --- a/src/mred/wxme/wx_medad.cxx +++ b/src/mred/wxme/wx_medad.cxx @@ -3,7 +3,7 @@ * Purpose: wxMediaCanvas & wxDrawableMediaAdmin implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt */ diff --git a/src/mred/wxme/wx_media.cxx b/src/mred/wxme/wx_media.cxx index 90abce7d02..254ce37ab6 100644 --- a/src/mred/wxme/wx_media.cxx +++ b/src/mred/wxme/wx_media.cxx @@ -3,7 +3,7 @@ * Purpose: wxMediaEdit implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_mline.cxx b/src/mred/wxme/wx_mline.cxx index 3101c56b80..afaa853190 100644 --- a/src/mred/wxme/wx_mline.cxx +++ b/src/mred/wxme/wx_mline.cxx @@ -3,7 +3,7 @@ * Purpose: wxMediaLine (internal class for wxMediaEdit) implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_mpbrd.cxx b/src/mred/wxme/wx_mpbrd.cxx index 17f6bb9730..98658ad4af 100644 --- a/src/mred/wxme/wx_mpbrd.cxx +++ b/src/mred/wxme/wx_mpbrd.cxx @@ -3,7 +3,7 @@ * Purpose: wxMediaPasteboard implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_mpriv.cxx b/src/mred/wxme/wx_mpriv.cxx index b5baa02867..310222c76d 100644 --- a/src/mred/wxme/wx_mpriv.cxx +++ b/src/mred/wxme/wx_mpriv.cxx @@ -3,7 +3,7 @@ * Purpose: wxMediaEdit private methods implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_msnip.cxx b/src/mred/wxme/wx_msnip.cxx index 2b0516f06d..8955719fb8 100644 --- a/src/mred/wxme/wx_msnip.cxx +++ b/src/mred/wxme/wx_msnip.cxx @@ -3,7 +3,7 @@ * Purpose: wxMediaSnip implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_snip.cxx b/src/mred/wxme/wx_snip.cxx index 1c263d1d52..b30e47d55b 100644 --- a/src/mred/wxme/wx_snip.cxx +++ b/src/mred/wxme/wx_snip.cxx @@ -3,7 +3,7 @@ * Purpose: wxSnip implementations * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995-2002, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mred/wxme/wx_style.cxx b/src/mred/wxme/wx_style.cxx index e1c57d6461..af6506447f 100644 --- a/src/mred/wxme/wx_style.cxx +++ b/src/mred/wxme/wx_style.cxx @@ -3,7 +3,7 @@ * Purpose: wxStyle and wxStyleList implementation * Author: Matthew Flatt * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/dynsrc/mzdyn.c b/src/mzscheme/dynsrc/mzdyn.c index 12c98a4fde..34fdf72941 100644 --- a/src/mzscheme/dynsrc/mzdyn.c +++ b/src/mzscheme/dynsrc/mzdyn.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/gc2/compact.c b/src/mzscheme/gc2/compact.c index 23caa937aa..6b0b1e3b2f 100644 --- a/src/mzscheme/gc2/compact.c +++ b/src/mzscheme/gc2/compact.c @@ -1,6 +1,6 @@ /* Precise GC for MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1999 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/gc2/copy.c b/src/mzscheme/gc2/copy.c index 6bbe596cef..a95d62e21e 100644 --- a/src/mzscheme/gc2/copy.c +++ b/src/mzscheme/gc2/copy.c @@ -1,6 +1,6 @@ /* Precise GC for MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1999 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/include/escheme.h b/src/mzscheme/include/escheme.h index c72724687b..5cc4162b3f 100644 --- a/src/mzscheme/include/escheme.h +++ b/src/mzscheme/include/escheme.h @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 1fdc0be8d3..db193f31da 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/main.c b/src/mzscheme/main.c index 06e593fbea..b2157d70ab 100644 --- a/src/mzscheme/main.c +++ b/src/mzscheme/main.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2000 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/sgc/sgc.c b/src/mzscheme/sgc/sgc.c index d3cfaedb47..4d8f0506ba 100644 --- a/src/mzscheme/sgc/sgc.c +++ b/src/mzscheme/sgc/sgc.c @@ -1,7 +1,7 @@ /* SenoraGC, a relatively portable conservative GC for a slightly cooperative environment - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1996-98 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/src/bignum.c b/src/mzscheme/src/bignum.c index 2048f796be..12fb65e68f 100644 --- a/src/mzscheme/src/bignum.c +++ b/src/mzscheme/src/bignum.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt, Scott Owens This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/bool.c b/src/mzscheme/src/bool.c index 9598f26687..1bdea7ad2f 100644 --- a/src/mzscheme/src/bool.c +++ b/src/mzscheme/src/bool.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/builtin.c b/src/mzscheme/src/builtin.c index e6d24dd256..e3c3150351 100644 --- a/src/mzscheme/src/builtin.c +++ b/src/mzscheme/src/builtin.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/char.c b/src/mzscheme/src/char.c index f360763ebd..0d383272c6 100644 --- a/src/mzscheme/src/char.c +++ b/src/mzscheme/src/char.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/complex.c b/src/mzscheme/src/complex.c index 217c5e3258..0a74a59410 100644 --- a/src/mzscheme/src/complex.c +++ b/src/mzscheme/src/complex.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/dynext.c b/src/mzscheme/src/dynext.c index 745e8313f4..e38417d32c 100644 --- a/src/mzscheme/src/dynext.c +++ b/src/mzscheme/src/dynext.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2002 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 43affd3fea..2cd890ec5c 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 86f70f09f2..8237049fba 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index a90f03d47d..e93bcc8f90 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/file.c b/src/mzscheme/src/file.c index 8219ecb939..b7949a594e 100644 --- a/src/mzscheme/src/file.c +++ b/src/mzscheme/src/file.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index de0bf2d706..1bdb72da46 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/hash.c b/src/mzscheme/src/hash.c index 81438df3b7..e3c631d453 100644 --- a/src/mzscheme/src/hash.c +++ b/src/mzscheme/src/hash.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 9ae24f51ca..4b6fd1b0bf 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2006-2008 PLT Scheme Inc. + Copyright (c) 2006-2009 PLT Scheme Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public diff --git a/src/mzscheme/src/list.c b/src/mzscheme/src/list.c index 21d1d6d8df..4a4678781c 100644 --- a/src/mzscheme/src/list.c +++ b/src/mzscheme/src/list.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index bc37315a16..98efadf023 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/mzsj86.c b/src/mzscheme/src/mzsj86.c index aa687daf46..202b2116a0 100644 --- a/src/mzscheme/src/mzsj86.c +++ b/src/mzscheme/src/mzsj86.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/network.c b/src/mzscheme/src/network.c index 02f0a49762..f06f596f1e 100644 --- a/src/mzscheme/src/network.c +++ b/src/mzscheme/src/network.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/numarith.c b/src/mzscheme/src/numarith.c index 15b1b3f189..151bbe858c 100644 --- a/src/mzscheme/src/numarith.c +++ b/src/mzscheme/src/numarith.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c index 5e7972888b..90027d7f03 100644 --- a/src/mzscheme/src/number.c +++ b/src/mzscheme/src/number.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/numcomp.c b/src/mzscheme/src/numcomp.c index 950a9fb09a..324edab988 100644 --- a/src/mzscheme/src/numcomp.c +++ b/src/mzscheme/src/numcomp.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/nummacs.h b/src/mzscheme/src/nummacs.h index 0ddd4faeb8..24efc29770 100644 --- a/src/mzscheme/src/nummacs.h +++ b/src/mzscheme/src/nummacs.h @@ -1,6 +1,6 @@ /* Mzscheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/numstr.c b/src/mzscheme/src/numstr.c index 4a23466a94..2e584972e1 100644 --- a/src/mzscheme/src/numstr.c +++ b/src/mzscheme/src/numstr.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 2d1fd56220..9ef41d395c 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/portfun.c b/src/mzscheme/src/portfun.c index 9cc9cda1dd..5309de578e 100644 --- a/src/mzscheme/src/portfun.c +++ b/src/mzscheme/src/portfun.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c index 746f83350e..8bf974c8bd 100644 --- a/src/mzscheme/src/print.c +++ b/src/mzscheme/src/print.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/rational.c b/src/mzscheme/src/rational.c index 59d903816f..85ea6d30f2 100644 --- a/src/mzscheme/src/rational.c +++ b/src/mzscheme/src/rational.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index 8ed4ee2c56..6d6e4e5afe 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/regexp.c b/src/mzscheme/src/regexp.c index 02462158b9..e647a5b75f 100644 --- a/src/mzscheme/src/regexp.c +++ b/src/mzscheme/src/regexp.c @@ -1,7 +1,7 @@ /* * @(#)regexp.c 1.3 of 18 April 87 * Revised for PLT MzScheme, 1995-2001 - * Copyright (c) 2004-2008 PLT Scheme Inc. + * Copyright (c) 2004-2009 PLT Scheme Inc. * * Copyright (c) 1986 by University of Toronto. * Written by Henry Spencer. Not derived from licensed software. diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index 7117ccc58d..d8364aaef7 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index f77bb5417b..aed0cce1e2 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 93184822e0..49d8794b9b 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 655e9be56e..71f440ca72 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt All rights reserved. diff --git a/src/mzscheme/src/sema.c b/src/mzscheme/src/sema.c index 5a24a9b5a5..4980063a15 100644 --- a/src/mzscheme/src/sema.c +++ b/src/mzscheme/src/sema.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/setjmpup.c b/src/mzscheme/src/setjmpup.c index fcd23628ef..8aad99bf14 100644 --- a/src/mzscheme/src/setjmpup.c +++ b/src/mzscheme/src/setjmpup.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c index 3617841d9f..0623256870 100644 --- a/src/mzscheme/src/string.c +++ b/src/mzscheme/src/string.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -1940,7 +1940,7 @@ char *scheme_banner(void) else return "Welcome to MzScheme" " v" MZSCHEME_VERSION VERSION_SUFFIX - ", Copyright (c) 2004-2008 PLT Scheme Inc.\n"; + ", Copyright (c) 2004-2009 PLT Scheme Inc.\n"; } void scheme_set_banner(char *s) diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 58a0ecaea4..1f0472e9a7 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index a3854bbd06..d7726bdbff 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/symbol.c b/src/mzscheme/src/symbol.c index 46aec57962..a7b5db037c 100644 --- a/src/mzscheme/src/symbol.c +++ b/src/mzscheme/src/symbol.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 106b3f1c87..d46a952f0f 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 726b36c2d7..7c3460b74b 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 72049b5b9c..5f800c28fa 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/mzscheme/src/vector.c b/src/mzscheme/src/vector.c index 0d7ac3df36..78fc3c4aab 100644 --- a/src/mzscheme/src/vector.c +++ b/src/mzscheme/src/vector.c @@ -1,6 +1,6 @@ /* MzScheme - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/src/worksp/mred/mred.rc b/src/worksp/mred/mred.rc index f54ca5b8a8..f088cb921f 100644 --- a/src/worksp/mred/mred.rc +++ b/src/worksp/mred/mred.rc @@ -40,7 +40,7 @@ BEGIN VALUE "FileDescription", "PLT Scheme GUI application\0" VALUE "InternalName", "MrEd\0" VALUE "FileVersion", "4, 1, 3, 8\0" - VALUE "LegalCopyright", "Copyright 1995-2008\0" + VALUE "LegalCopyright", "Copyright 1995-2009\0" VALUE "OriginalFilename", "MrEd.exe\0" VALUE "ProductName", "PLT Scheme\0" VALUE "ProductVersion", "4, 1, 3, 8\0" diff --git a/src/worksp/mzcom/mzcom.rc b/src/worksp/mzcom/mzcom.rc index a4116c967b..7561928aa8 100644 --- a/src/worksp/mzcom/mzcom.rc +++ b/src/worksp/mzcom/mzcom.rc @@ -72,7 +72,7 @@ BEGIN VALUE "FileDescription", "MzCOM Module" VALUE "FileVersion", "4, 1, 3, 8" VALUE "InternalName", "MzCOM" - VALUE "LegalCopyright", "Copyright 2000-2008 PLT (Paul Steckler)" + VALUE "LegalCopyright", "Copyright 2000-2009 PLT (Paul Steckler)" VALUE "OriginalFilename", "MzCOM.EXE" VALUE "ProductName", "MzCOM Module" VALUE "ProductVersion", "4, 1, 3, 8" @@ -106,10 +106,10 @@ FONT 8, "MS Sans Serif", 0, 0, 0x0 BEGIN DEFPUSHBUTTON "OK",IDOK,76,69,50,14,BS_CENTER CTEXT "MzCOM v. 4.1",IDC_STATIC,71,8,61,8 - CTEXT "Copyright (c) 2000-2008 PLT (Paul Steckler)",IDC_STATIC, + CTEXT "Copyright (c) 2000-2009 PLT (Paul Steckler)",IDC_STATIC, 41,20,146,9 CTEXT "MzScheme v. 4.1",IDC_STATIC,64,35,75,8 - CTEXT "Copyright (c) 1995-2008 PLT Inc.",IDC_STATIC, + CTEXT "Copyright (c) 1995-2009 PLT Inc.",IDC_STATIC, 30,47,143,8 ICON MZICON,IDC_STATIC,11,16,20,20 END diff --git a/src/worksp/mzscheme/mzscheme.rc b/src/worksp/mzscheme/mzscheme.rc index 65e3457790..294c30660f 100644 --- a/src/worksp/mzscheme/mzscheme.rc +++ b/src/worksp/mzscheme/mzscheme.rc @@ -49,7 +49,7 @@ BEGIN VALUE "FileDescription", "PLT Scheme application\0" VALUE "InternalName", "MzScheme\0" VALUE "FileVersion", "4, 1, 3, 8\0" - VALUE "LegalCopyright", "Copyright 1995-2008\0" + VALUE "LegalCopyright", "Copyright 1995-2009\0" VALUE "OriginalFilename", "mzscheme.exe\0" VALUE "ProductName", "PLT Scheme\0" VALUE "ProductVersion", "4, 1, 3, 8\0" diff --git a/src/worksp/starters/start.rc b/src/worksp/starters/start.rc index 9935b35941..3e8a93261f 100644 --- a/src/worksp/starters/start.rc +++ b/src/worksp/starters/start.rc @@ -52,7 +52,7 @@ BEGIN #ifdef MZSTART VALUE "InternalName", "mzstart\0" #endif - VALUE "LegalCopyright", "Copyright 1996-2008\0" + VALUE "LegalCopyright", "Copyright 1996-2009\0" #ifdef MRSTART VALUE "OriginalFilename", "MrStart.exe\0" #endif diff --git a/src/wxcommon/FontDirectory.cxx b/src/wxcommon/FontDirectory.cxx index 83b81cf94c..2ca99c498f 100644 --- a/src/wxcommon/FontDirectory.cxx +++ b/src/wxcommon/FontDirectory.cxx @@ -4,7 +4,7 @@ * * Authors: Markus Holzem, Julian Smart, and Matthew Flatt * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxcommon/FontDirectory.h b/src/wxcommon/FontDirectory.h index de33417532..a30039d707 100644 --- a/src/wxcommon/FontDirectory.h +++ b/src/wxcommon/FontDirectory.h @@ -5,7 +5,7 @@ * * Authors: Markus Holzem, Julian Smart, and Matthew Flatt * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxcommon/PSDC.cxx b/src/wxcommon/PSDC.cxx index a0ecff7ebd..7998210502 100644 --- a/src/wxcommon/PSDC.cxx +++ b/src/wxcommon/PSDC.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxcommon/PSDC.h b/src/wxcommon/PSDC.h index 470004d081..d36212ade3 100644 --- a/src/wxcommon/PSDC.h +++ b/src/wxcommon/PSDC.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxcommon/wb_hash.cxx b/src/wxcommon/wb_hash.cxx index 5eaa0c3605..84c5be8819 100644 --- a/src/wxcommon/wb_hash.cxx +++ b/src/wxcommon/wb_hash.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxcommon/wb_list.cxx b/src/wxcommon/wb_list.cxx index c2f08be10b..c7d864d0a2 100644 --- a/src/wxcommon/wb_list.cxx +++ b/src/wxcommon/wb_list.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxcommon/wxGC.cxx b/src/wxcommon/wxGC.cxx index 31f523775d..4baa00934c 100644 --- a/src/wxcommon/wxGC.cxx +++ b/src/wxcommon/wxGC.cxx @@ -3,7 +3,7 @@ MrEd interface to various garbage collectors, including the Boehm collector, SenoraGC, and MzScheme's precise collector. -Copyright (c) 2004-2008 PLT Scheme Inc. +Copyright (c) 2004-2009 PLT Scheme Inc. *************************************************************************/ diff --git a/src/wxcommon/wxGC.h b/src/wxcommon/wxGC.h index a0e8045342..71eae2bdb9 100644 --- a/src/wxcommon/wxGC.h +++ b/src/wxcommon/wxGC.h @@ -6,7 +6,7 @@ MrEd interface to various garbage collectors, including the Boehm collector, SenoraGC, and MzScheme's precise collector. -Copyright (c) 2004-2008 PLT Scheme Inc. +Copyright (c) 2004-2009 PLT Scheme Inc. ****************************************************************************/ diff --git a/src/wxcommon/wx_hash.h b/src/wxcommon/wx_hash.h index e1829db3ba..8add629a95 100644 --- a/src/wxcommon/wx_hash.h +++ b/src/wxcommon/wx_hash.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxcommon/wx_list.h b/src/wxcommon/wx_list.h index e089868ca5..bca0cbc515 100644 --- a/src/wxcommon/wx_list.h +++ b/src/wxcommon/wx_list.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/common.h b/src/wxmac/include/base/common.h index 67d353d907..6218a3ffe8 100644 --- a/src/wxmac/include/base/common.h +++ b/src/wxmac/include/base/common.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_buttn.h b/src/wxmac/include/base/wb_buttn.h index 2137e2fcc8..2e245e6b8e 100644 --- a/src/wxmac/include/base/wb_buttn.h +++ b/src/wxmac/include/base/wb_buttn.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_canvs.h b/src/wxmac/include/base/wb_canvs.h index 739be646b8..827fbc6155 100644 --- a/src/wxmac/include/base/wb_canvs.h +++ b/src/wxmac/include/base/wb_canvs.h @@ -5,7 +5,7 @@ * Created: 1993 * Updated: * 7/3/95 pulled in some 16.2 changes - Cecil Coupe - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_check.h b/src/wxmac/include/base/wb_check.h index c3f3640485..f8fcfcf67e 100644 --- a/src/wxmac/include/base/wb_check.h +++ b/src/wxmac/include/base/wb_check.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_choic.h b/src/wxmac/include/base/wb_choic.h index b60fe57c4d..c26a5e143f 100644 --- a/src/wxmac/include/base/wb_choic.h +++ b/src/wxmac/include/base/wb_choic.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_dc.h b/src/wxmac/include/base/wb_dc.h index e7cd468747..a456280cb1 100644 --- a/src/wxmac/include/base/wb_dc.h +++ b/src/wxmac/include/base/wb_dc.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_dccan.h b/src/wxmac/include/base/wb_dccan.h index ad3e14d455..6b3cca283c 100644 --- a/src/wxmac/include/base/wb_dccan.h +++ b/src/wxmac/include/base/wb_dccan.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_dcmem.h b/src/wxmac/include/base/wb_dcmem.h index 51f38b9e08..8135a172d9 100644 --- a/src/wxmac/include/base/wb_dcmem.h +++ b/src/wxmac/include/base/wb_dcmem.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_dialg.h b/src/wxmac/include/base/wb_dialg.h index e1dd64f3cf..68f7e61f13 100644 --- a/src/wxmac/include/base/wb_dialg.h +++ b/src/wxmac/include/base/wb_dialg.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_frame.h b/src/wxmac/include/base/wb_frame.h index 3d329f9e42..5532820974 100644 --- a/src/wxmac/include/base/wb_frame.h +++ b/src/wxmac/include/base/wb_frame.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_gauge.h b/src/wxmac/include/base/wb_gauge.h index d7a9b361c0..6610d52454 100644 --- a/src/wxmac/include/base/wb_gauge.h +++ b/src/wxmac/include/base/wb_gauge.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_gdi.h b/src/wxmac/include/base/wb_gdi.h index ae7e0e6394..ef6430bcc3 100644 --- a/src/wxmac/include/base/wb_gdi.h +++ b/src/wxmac/include/base/wb_gdi.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_item.h b/src/wxmac/include/base/wb_item.h index 79e111c6c4..f70f96028e 100644 --- a/src/wxmac/include/base/wb_item.h +++ b/src/wxmac/include/base/wb_item.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_lbox.h b/src/wxmac/include/base/wb_lbox.h index e3124e9087..ad567dceb6 100644 --- a/src/wxmac/include/base/wb_lbox.h +++ b/src/wxmac/include/base/wb_lbox.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_main.h b/src/wxmac/include/base/wb_main.h index f8a417bf77..f6d9c91ef5 100644 --- a/src/wxmac/include/base/wb_main.h +++ b/src/wxmac/include/base/wb_main.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_menu.h b/src/wxmac/include/base/wb_menu.h index da3a4795b5..50fe11e04c 100644 --- a/src/wxmac/include/base/wb_menu.h +++ b/src/wxmac/include/base/wb_menu.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_messg.h b/src/wxmac/include/base/wb_messg.h index e486150a18..db0951319e 100644 --- a/src/wxmac/include/base/wb_messg.h +++ b/src/wxmac/include/base/wb_messg.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_mnuit.h b/src/wxmac/include/base/wb_mnuit.h index 527ceea57b..bc560eb7c5 100644 --- a/src/wxmac/include/base/wb_mnuit.h +++ b/src/wxmac/include/base/wb_mnuit.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_panel.h b/src/wxmac/include/base/wb_panel.h index edaae4b9b4..0f677e5ba1 100644 --- a/src/wxmac/include/base/wb_panel.h +++ b/src/wxmac/include/base/wb_panel.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_rbox.h b/src/wxmac/include/base/wb_rbox.h index 053d9ecbaf..6a4cdc0125 100644 --- a/src/wxmac/include/base/wb_rbox.h +++ b/src/wxmac/include/base/wb_rbox.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_slidr.h b/src/wxmac/include/base/wb_slidr.h index 5715ab5375..d201d56947 100644 --- a/src/wxmac/include/base/wb_slidr.h +++ b/src/wxmac/include/base/wb_slidr.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_timer.h b/src/wxmac/include/base/wb_timer.h index 71218a1514..784d4d5038 100644 --- a/src/wxmac/include/base/wb_timer.h +++ b/src/wxmac/include/base/wb_timer.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wb_win.h b/src/wxmac/include/base/wb_win.h index 6fbcb5da95..0ba725f763 100644 --- a/src/wxmac/include/base/wb_win.h +++ b/src/wxmac/include/base/wb_win.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wx.h b/src/wxmac/include/base/wx.h index 329d1dc988..99c8b81502 100644 --- a/src/wxmac/include/base/wx.h +++ b/src/wxmac/include/base/wx.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wx_clipb.h b/src/wxmac/include/base/wx_clipb.h index 06481065f8..5e7a7884f1 100644 --- a/src/wxmac/include/base/wx_clipb.h +++ b/src/wxmac/include/base/wx_clipb.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wx_obj.h b/src/wxmac/include/base/wx_obj.h index 5a593abb37..fe6670a9ec 100644 --- a/src/wxmac/include/base/wx_obj.h +++ b/src/wxmac/include/base/wx_obj.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wx_setup.h b/src/wxmac/include/base/wx_setup.h index 9e913b0930..abe32a8092 100644 --- a/src/wxmac/include/base/wx_setup.h +++ b/src/wxmac/include/base/wx_setup.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wx_stdev.h b/src/wxmac/include/base/wx_stdev.h index 8e1701ef6b..440f33946b 100644 --- a/src/wxmac/include/base/wx_stdev.h +++ b/src/wxmac/include/base/wx_stdev.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wx_sysev.h b/src/wxmac/include/base/wx_sysev.h index 013799aa1f..b69ae717e7 100644 --- a/src/wxmac/include/base/wx_sysev.h +++ b/src/wxmac/include/base/wx_sysev.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wx_types.h b/src/wxmac/include/base/wx_types.h index c530553e27..00495b81a4 100644 --- a/src/wxmac/include/base/wx_types.h +++ b/src/wxmac/include/base/wx_types.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/base/wx_utils.h b/src/wxmac/include/base/wx_utils.h index 43f45635b8..95b82cbf43 100644 --- a/src/wxmac/include/base/wx_utils.h +++ b/src/wxmac/include/base/wx_utils.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: Oct 7, 1995 - Cecil Coupe, added wxRmdir() prototype - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/mac/wxBorder.h b/src/wxmac/include/mac/wxBorder.h index 7cfdff0be0..471c2916bc 100644 --- a/src/wxmac/include/mac/wxBorder.h +++ b/src/wxmac/include/mac/wxBorder.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxBorderArea.h b/src/wxmac/include/mac/wxBorderArea.h index 42f2e195a7..85f097dbac 100644 --- a/src/wxmac/include/mac/wxBorderArea.h +++ b/src/wxmac/include/mac/wxBorderArea.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxButtonBorder.h b/src/wxmac/include/mac/wxButtonBorder.h index c0f707d445..d92eb0a7d3 100644 --- a/src/wxmac/include/mac/wxButtonBorder.h +++ b/src/wxmac/include/mac/wxButtonBorder.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxDirection.h b/src/wxmac/include/mac/wxDirection.h index 021c91a7f5..b01e4c46fe 100644 --- a/src/wxmac/include/mac/wxDirection.h +++ b/src/wxmac/include/mac/wxDirection.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxLabelArea.h b/src/wxmac/include/mac/wxLabelArea.h index a94c52c765..49e014f224 100644 --- a/src/wxmac/include/mac/wxLabelArea.h +++ b/src/wxmac/include/mac/wxLabelArea.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxMacDC.h b/src/wxmac/include/mac/wxMacDC.h index cd3d9c37df..5ceb438487 100644 --- a/src/wxmac/include/mac/wxMacDC.h +++ b/src/wxmac/include/mac/wxMacDC.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxMargin.h b/src/wxmac/include/mac/wxMargin.h index 298351986f..35b6af5398 100644 --- a/src/wxmac/include/mac/wxMargin.h +++ b/src/wxmac/include/mac/wxMargin.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxRectBorder.h b/src/wxmac/include/mac/wxRectBorder.h index 292e50a863..94e5eac0dc 100644 --- a/src/wxmac/include/mac/wxRectBorder.h +++ b/src/wxmac/include/mac/wxRectBorder.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxScroll.h b/src/wxmac/include/mac/wxScroll.h index 0b4d12b7dd..5824cf2709 100644 --- a/src/wxmac/include/mac/wxScroll.h +++ b/src/wxmac/include/mac/wxScroll.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxScrollArea.h b/src/wxmac/include/mac/wxScrollArea.h index e0d814dad9..8674ae33b3 100644 --- a/src/wxmac/include/mac/wxScrollArea.h +++ b/src/wxmac/include/mac/wxScrollArea.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wxScrollData.h b/src/wxmac/include/mac/wxScrollData.h index 7f3708b527..e9141ccde4 100644 --- a/src/wxmac/include/mac/wxScrollData.h +++ b/src/wxmac/include/mac/wxScrollData.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_area.h b/src/wxmac/include/mac/wx_area.h index 9cecfb3453..5c5287e605 100644 --- a/src/wxmac/include/mac/wx_area.h +++ b/src/wxmac/include/mac/wx_area.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_buttn.h b/src/wxmac/include/mac/wx_buttn.h index 6ade608e70..ecb54b7292 100644 --- a/src/wxmac/include/mac/wx_buttn.h +++ b/src/wxmac/include/mac/wx_buttn.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_canvs.h b/src/wxmac/include/mac/wx_canvs.h index fd63e7027e..54274eea49 100644 --- a/src/wxmac/include/mac/wx_canvs.h +++ b/src/wxmac/include/mac/wx_canvs.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_check.h b/src/wxmac/include/mac/wx_check.h index b20fd2b4f3..39283d0ae2 100644 --- a/src/wxmac/include/mac/wx_check.h +++ b/src/wxmac/include/mac/wx_check.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_choic.h b/src/wxmac/include/mac/wx_choic.h index d5cc0803e6..16454c9d23 100644 --- a/src/wxmac/include/mac/wx_choic.h +++ b/src/wxmac/include/mac/wx_choic.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/mac/wx_dc.h b/src/wxmac/include/mac/wx_dc.h index 7869298830..79cc2cea04 100644 --- a/src/wxmac/include/mac/wx_dc.h +++ b/src/wxmac/include/mac/wx_dc.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_dccan.h b/src/wxmac/include/mac/wx_dccan.h index 772792aa4a..31c6c97589 100644 --- a/src/wxmac/include/mac/wx_dccan.h +++ b/src/wxmac/include/mac/wx_dccan.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_dcmem.h b/src/wxmac/include/mac/wx_dcmem.h index 8ae49ccf2f..dfacca1123 100644 --- a/src/wxmac/include/mac/wx_dcmem.h +++ b/src/wxmac/include/mac/wx_dcmem.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. */ diff --git a/src/wxmac/include/mac/wx_dcpr.h b/src/wxmac/include/mac/wx_dcpr.h index dd05062eac..0ce7e71506 100644 --- a/src/wxmac/include/mac/wx_dcpr.h +++ b/src/wxmac/include/mac/wx_dcpr.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_dialg.h b/src/wxmac/include/mac/wx_dialg.h index faf387cd88..f511bcab12 100644 --- a/src/wxmac/include/mac/wx_dialg.h +++ b/src/wxmac/include/mac/wx_dialg.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_frame.h b/src/wxmac/include/mac/wx_frame.h index 9453e05466..a0e314e951 100644 --- a/src/wxmac/include/mac/wx_frame.h +++ b/src/wxmac/include/mac/wx_frame.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_gauge.h b/src/wxmac/include/mac/wx_gauge.h index 79cb808dd3..cf9e285c28 100644 --- a/src/wxmac/include/mac/wx_gauge.h +++ b/src/wxmac/include/mac/wx_gauge.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/mac/wx_gbox.h b/src/wxmac/include/mac/wx_gbox.h index 9a053d9a7e..1797cff676 100644 --- a/src/wxmac/include/mac/wx_gbox.h +++ b/src/wxmac/include/mac/wx_gbox.h @@ -3,7 +3,7 @@ * Purpose: Tab group panel item * Author: Matthew * Created: 2002 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 2002, PLT */ diff --git a/src/wxmac/include/mac/wx_gdi.h b/src/wxmac/include/mac/wx_gdi.h index 6a30f5395b..61fbf325c9 100644 --- a/src/wxmac/include/mac/wx_gdi.h +++ b/src/wxmac/include/mac/wx_gdi.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_item.h b/src/wxmac/include/mac/wx_item.h index 959821dfd8..02e692f82d 100644 --- a/src/wxmac/include/mac/wx_item.h +++ b/src/wxmac/include/mac/wx_item.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_lbox.h b/src/wxmac/include/mac/wx_lbox.h index 37cc5d06c5..0349d7312a 100644 --- a/src/wxmac/include/mac/wx_lbox.h +++ b/src/wxmac/include/mac/wx_lbox.h @@ -4,7 +4,7 @@ * Author: Julian Smart/Cecil Coupe (mac version) * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/mac/wx_mac_utils.h b/src/wxmac/include/mac/wx_mac_utils.h index 2ba82a9874..2a20aef3a5 100644 --- a/src/wxmac/include/mac/wx_mac_utils.h +++ b/src/wxmac/include/mac/wx_mac_utils.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_main.h b/src/wxmac/include/mac/wx_main.h index 4fa9965eb8..60ada1f712 100644 --- a/src/wxmac/include/mac/wx_main.h +++ b/src/wxmac/include/mac/wx_main.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_menu.h b/src/wxmac/include/mac/wx_menu.h index c3ef9645f3..e7f67c21e7 100644 --- a/src/wxmac/include/mac/wx_menu.h +++ b/src/wxmac/include/mac/wx_menu.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_messg.h b/src/wxmac/include/mac/wx_messg.h index 6344aef59b..6ccee843f5 100644 --- a/src/wxmac/include/mac/wx_messg.h +++ b/src/wxmac/include/mac/wx_messg.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_mnuit.h b/src/wxmac/include/mac/wx_mnuit.h index 90c51ad430..fa9b3bac3b 100644 --- a/src/wxmac/include/mac/wx_mnuit.h +++ b/src/wxmac/include/mac/wx_mnuit.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_panel.h b/src/wxmac/include/mac/wx_panel.h index 325700cc03..0fccf04eb7 100644 --- a/src/wxmac/include/mac/wx_panel.h +++ b/src/wxmac/include/mac/wx_panel.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_print.h b/src/wxmac/include/mac/wx_print.h index c369665503..24b5bebdd5 100644 --- a/src/wxmac/include/mac/wx_print.h +++ b/src/wxmac/include/mac/wx_print.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1995 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/mac/wx_rbox.h b/src/wxmac/include/mac/wx_rbox.h index 160c96f5c2..da6f7a0b6c 100644 --- a/src/wxmac/include/mac/wx_rbox.h +++ b/src/wxmac/include/mac/wx_rbox.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_rbut.h b/src/wxmac/include/mac/wx_rbut.h index f1e7482ce1..c3712437ab 100644 --- a/src/wxmac/include/mac/wx_rbut.h +++ b/src/wxmac/include/mac/wx_rbut.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_sbar.h b/src/wxmac/include/mac/wx_sbar.h index c4380d1af9..a493db7768 100644 --- a/src/wxmac/include/mac/wx_sbar.h +++ b/src/wxmac/include/mac/wx_sbar.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_screen.h b/src/wxmac/include/mac/wx_screen.h index f6a3bb8244..22703f343f 100644 --- a/src/wxmac/include/mac/wx_screen.h +++ b/src/wxmac/include/mac/wx_screen.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wx_slidr.h b/src/wxmac/include/mac/wx_slidr.h index a970cc2d83..0889825420 100644 --- a/src/wxmac/include/mac/wx_slidr.h +++ b/src/wxmac/include/mac/wx_slidr.h @@ -4,7 +4,7 @@ * Author: Julian Smart (Cecil Coupe) * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/mac/wx_tabc.h b/src/wxmac/include/mac/wx_tabc.h index 7a9d332d41..79f4bdda1b 100644 --- a/src/wxmac/include/mac/wx_tabc.h +++ b/src/wxmac/include/mac/wx_tabc.h @@ -3,7 +3,7 @@ * Purpose: Tab group panel item * Author: Matthew * Created: 2002 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 2002, PLT */ diff --git a/src/wxmac/include/mac/wx_timer.h b/src/wxmac/include/mac/wx_timer.h index 9dea851613..4f7a82bfc7 100644 --- a/src/wxmac/include/mac/wx_timer.h +++ b/src/wxmac/include/mac/wx_timer.h @@ -4,7 +4,7 @@ * Author: Julian Smart/Cecil Coupe * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/include/mac/wx_win.h b/src/wxmac/include/mac/wx_win.h index c40ca538d2..41ecdb55f0 100644 --- a/src/wxmac/include/mac/wx_win.h +++ b/src/wxmac/include/mac/wx_win.h @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/include/mac/wximgfil.h b/src/wxmac/include/mac/wximgfil.h index cd3ecd1dde..6abaac1e19 100644 --- a/src/wxmac/include/mac/wximgfil.h +++ b/src/wxmac/include/mac/wximgfil.h @@ -3,7 +3,7 @@ * Purpose: Declaration of the Platform Independent GIF Image Class * Author: Alejandro Aguilar Sierra * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Alejandro Aguilar Sierra */ #if !defined(__wximgfil_h) diff --git a/src/wxmac/src/base/wb_canvs.cc b/src/wxmac/src/base/wb_canvs.cc index bcf8f5ac5e..1ad110ecbd 100644 --- a/src/wxmac/src/base/wb_canvs.cc +++ b/src/wxmac/src/base/wb_canvs.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_dc.cc b/src/wxmac/src/base/wb_dc.cc index da79cdc030..ea547477d1 100644 --- a/src/wxmac/src/base/wb_dc.cc +++ b/src/wxmac/src/base/wb_dc.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_dialg.cc b/src/wxmac/src/base/wb_dialg.cc index 1aa5f4079e..553ea8fc78 100644 --- a/src/wxmac/src/base/wb_dialg.cc +++ b/src/wxmac/src/base/wb_dialg.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_frame.cc b/src/wxmac/src/base/wb_frame.cc index cb787d9316..da4fe46841 100644 --- a/src/wxmac/src/base/wb_frame.cc +++ b/src/wxmac/src/base/wb_frame.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_gdi.cc b/src/wxmac/src/base/wb_gdi.cc index 39056844ce..bbe9d85e79 100644 --- a/src/wxmac/src/base/wb_gdi.cc +++ b/src/wxmac/src/base/wb_gdi.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_item.cc b/src/wxmac/src/base/wb_item.cc index 89ba12babd..b835c4b0cc 100644 --- a/src/wxmac/src/base/wb_item.cc +++ b/src/wxmac/src/base/wb_item.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_main.cc b/src/wxmac/src/base/wb_main.cc index 5009f6f9b0..cedf82453b 100644 --- a/src/wxmac/src/base/wb_main.cc +++ b/src/wxmac/src/base/wb_main.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_obj.cc b/src/wxmac/src/base/wb_obj.cc index 0d194a7a2c..364e150e3e 100644 --- a/src/wxmac/src/base/wb_obj.cc +++ b/src/wxmac/src/base/wb_obj.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_panel.cc b/src/wxmac/src/base/wb_panel.cc index f894508870..7a8654d3a5 100644 --- a/src/wxmac/src/base/wb_panel.cc +++ b/src/wxmac/src/base/wb_panel.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_stdev.cc b/src/wxmac/src/base/wb_stdev.cc index 113099cb79..114abb9264 100644 --- a/src/wxmac/src/base/wb_stdev.cc +++ b/src/wxmac/src/base/wb_stdev.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_sysev.cc b/src/wxmac/src/base/wb_sysev.cc index f6f53d0b29..9346327dea 100644 --- a/src/wxmac/src/base/wb_sysev.cc +++ b/src/wxmac/src/base/wb_sysev.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_timer.cc b/src/wxmac/src/base/wb_timer.cc index bbbdc98289..25afbe8ca5 100644 --- a/src/wxmac/src/base/wb_timer.cc +++ b/src/wxmac/src/base/wb_timer.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_types.cc b/src/wxmac/src/base/wb_types.cc index 46720725c2..0ba21ecc69 100644 --- a/src/wxmac/src/base/wb_types.cc +++ b/src/wxmac/src/base/wb_types.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_utils.cc b/src/wxmac/src/base/wb_utils.cc index f90a210dd0..e00c3bffa3 100644 --- a/src/wxmac/src/base/wb_utils.cc +++ b/src/wxmac/src/base/wb_utils.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/wb_win.cc b/src/wxmac/src/base/wb_win.cc index e45c8b24bf..ca4df8293b 100644 --- a/src/wxmac/src/base/wb_win.cc +++ b/src/wxmac/src/base/wb_win.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/base/xfspline.cc b/src/wxmac/src/base/xfspline.cc index 04841f77cb..3ed18a55df 100644 --- a/src/wxmac/src/base/xfspline.cc +++ b/src/wxmac/src/base/xfspline.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/mac/wxBorder.cc b/src/wxmac/src/mac/wxBorder.cc index a39cc2959b..e26d3bccaa 100644 --- a/src/wxmac/src/mac/wxBorder.cc +++ b/src/wxmac/src/mac/wxBorder.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxBorderArea.cc b/src/wxmac/src/mac/wxBorderArea.cc index b326f6d34a..fe4103033a 100644 --- a/src/wxmac/src/mac/wxBorderArea.cc +++ b/src/wxmac/src/mac/wxBorderArea.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxButtonBorder.cc b/src/wxmac/src/mac/wxButtonBorder.cc index faf9bc4fad..ee8a4cd857 100644 --- a/src/wxmac/src/mac/wxButtonBorder.cc +++ b/src/wxmac/src/mac/wxButtonBorder.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxLabelArea.cc b/src/wxmac/src/mac/wxLabelArea.cc index 834bcc7122..a6d768806e 100644 --- a/src/wxmac/src/mac/wxLabelArea.cc +++ b/src/wxmac/src/mac/wxLabelArea.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxMacDC.cc b/src/wxmac/src/mac/wxMacDC.cc index ef94a3673b..d96897d2e2 100644 --- a/src/wxmac/src/mac/wxMacDC.cc +++ b/src/wxmac/src/mac/wxMacDC.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxMargin.cc b/src/wxmac/src/mac/wxMargin.cc index c444226552..ec1e62e126 100644 --- a/src/wxmac/src/mac/wxMargin.cc +++ b/src/wxmac/src/mac/wxMargin.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxRectBorder.cc b/src/wxmac/src/mac/wxRectBorder.cc index 7d84fe59da..682f985bc6 100644 --- a/src/wxmac/src/mac/wxRectBorder.cc +++ b/src/wxmac/src/mac/wxRectBorder.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxScroll.cc b/src/wxmac/src/mac/wxScroll.cc index 790ac59bfb..f3b492d218 100644 --- a/src/wxmac/src/mac/wxScroll.cc +++ b/src/wxmac/src/mac/wxScroll.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxScrollArea.cc b/src/wxmac/src/mac/wxScrollArea.cc index 5c1f9240f0..b7d5a5e4e3 100644 --- a/src/wxmac/src/mac/wxScrollArea.cc +++ b/src/wxmac/src/mac/wxScrollArea.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wxScrollData.cc b/src/wxmac/src/mac/wxScrollData.cc index 683745a125..29cc85ffd3 100644 --- a/src/wxmac/src/mac/wxScrollData.cc +++ b/src/wxmac/src/mac/wxScrollData.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_app.cc b/src/wxmac/src/mac/wx_app.cc index aa1820854b..3586ed2783 100644 --- a/src/wxmac/src/mac/wx_app.cc +++ b/src/wxmac/src/mac/wx_app.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. //////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_area.cc b/src/wxmac/src/mac/wx_area.cc index 5285301bc0..00b4705e4b 100644 --- a/src/wxmac/src/mac/wx_area.cc +++ b/src/wxmac/src/mac/wx_area.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_buttn.cc b/src/wxmac/src/mac/wx_buttn.cc index b2dde7a6e5..5a32273660 100644 --- a/src/wxmac/src/mac/wx_buttn.cc +++ b/src/wxmac/src/mac/wx_buttn.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_canvs.cc b/src/wxmac/src/mac/wx_canvs.cc index 48e5fb73fa..c7c4a5232b 100644 --- a/src/wxmac/src/mac/wx_canvs.cc +++ b/src/wxmac/src/mac/wx_canvs.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_check.cc b/src/wxmac/src/mac/wx_check.cc index 4578cdbada..8a16e6cf2b 100644 --- a/src/wxmac/src/mac/wx_check.cc +++ b/src/wxmac/src/mac/wx_check.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_choic.cc b/src/wxmac/src/mac/wx_choic.cc index 05b47cde13..0ccdbe74dd 100644 --- a/src/wxmac/src/mac/wx_choic.cc +++ b/src/wxmac/src/mac/wx_choic.cc @@ -6,7 +6,7 @@ * Updated: April 1995 * July 22, 1995 - First Mac version - Cecil Coupe * - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/mac/wx_clipb.cc b/src/wxmac/src/mac/wx_clipb.cc index 31d0798da3..6ccaa8673c 100644 --- a/src/wxmac/src/mac/wx_clipb.cc +++ b/src/wxmac/src/mac/wx_clipb.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. */ diff --git a/src/wxmac/src/mac/wx_dc.cc b/src/wxmac/src/mac/wx_dc.cc index f5fcde781f..0537cae8b4 100644 --- a/src/wxmac/src/mac/wx_dc.cc +++ b/src/wxmac/src/mac/wx_dc.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_dccan1.cc b/src/wxmac/src/mac/wx_dccan1.cc index 1d32edd95d..c8fdf3ae77 100644 --- a/src/wxmac/src/mac/wx_dccan1.cc +++ b/src/wxmac/src/mac/wx_dccan1.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_dccan2.cc b/src/wxmac/src/mac/wx_dccan2.cc index a64e91ef88..f3bd4f3c5d 100644 --- a/src/wxmac/src/mac/wx_dccan2.cc +++ b/src/wxmac/src/mac/wx_dccan2.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_dccan3.cc b/src/wxmac/src/mac/wx_dccan3.cc index 5caeba64b9..0728fcbe4a 100644 --- a/src/wxmac/src/mac/wx_dccan3.cc +++ b/src/wxmac/src/mac/wx_dccan3.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_dcmem.cc b/src/wxmac/src/mac/wx_dcmem.cc index 7e299ea4bc..1d85d5a794 100644 --- a/src/wxmac/src/mac/wx_dcmem.cc +++ b/src/wxmac/src/mac/wx_dcmem.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_dialg.cc b/src/wxmac/src/mac/wx_dialg.cc index 33fa5b20ea..101d2f0a44 100644 --- a/src/wxmac/src/mac/wx_dialg.cc +++ b/src/wxmac/src/mac/wx_dialg.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_frame.cc b/src/wxmac/src/mac/wx_frame.cc index 3cedf03e20..4ed1fbed06 100644 --- a/src/wxmac/src/mac/wx_frame.cc +++ b/src/wxmac/src/mac/wx_frame.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_gauge.cc b/src/wxmac/src/mac/wx_gauge.cc index 2ed02f4b07..2717a12e57 100644 --- a/src/wxmac/src/mac/wx_gauge.cc +++ b/src/wxmac/src/mac/wx_gauge.cc @@ -4,7 +4,7 @@ * Author: Cecil Coupe * Created: 1995 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. */ diff --git a/src/wxmac/src/mac/wx_gbox.cc b/src/wxmac/src/mac/wx_gbox.cc index b4f64546c2..3fc70948bd 100644 --- a/src/wxmac/src/mac/wx_gbox.cc +++ b/src/wxmac/src/mac/wx_gbox.cc @@ -3,7 +3,7 @@ // Purpose: Panel item tab choice implementation (Macintosh version) // Author: Matthew // Created: 2002 -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 2002, PLT /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_gdi.cc b/src/wxmac/src/mac/wx_gdi.cc index e04d4e5a2c..8c28200fe8 100644 --- a/src/wxmac/src/mac/wx_gdi.cc +++ b/src/wxmac/src/mac/wx_gdi.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_item.cc b/src/wxmac/src/mac/wx_item.cc index 7dcf1b0376..5efab5b193 100644 --- a/src/wxmac/src/mac/wx_item.cc +++ b/src/wxmac/src/mac/wx_item.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_lbox.cc b/src/wxmac/src/mac/wx_lbox.cc index 221c9e9bb7..34f7d99789 100644 --- a/src/wxmac/src/mac/wx_lbox.cc +++ b/src/wxmac/src/mac/wx_lbox.cc @@ -5,7 +5,7 @@ * Created: 1994 * Updated: * 11/1/95 - not deleting client data on delete or clear - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. */ diff --git a/src/wxmac/src/mac/wx_mac_utils.cc b/src/wxmac/src/mac/wx_mac_utils.cc index 710c9debfd..ba35a279b4 100644 --- a/src/wxmac/src/mac/wx_mac_utils.cc +++ b/src/wxmac/src/mac/wx_mac_utils.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_main.cc b/src/wxmac/src/mac/wx_main.cc index 8153ae558c..9dc924383c 100644 --- a/src/wxmac/src/mac/wx_main.cc +++ b/src/wxmac/src/mac/wx_main.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_menu.cc b/src/wxmac/src/mac/wx_menu.cc index 6e69756be6..ede59182dc 100644 --- a/src/wxmac/src/mac/wx_menu.cc +++ b/src/wxmac/src/mac/wx_menu.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_messg.cc b/src/wxmac/src/mac/wx_messg.cc index b9427202d7..ed56f1d21a 100644 --- a/src/wxmac/src/mac/wx_messg.cc +++ b/src/wxmac/src/mac/wx_messg.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_mnuit.cc b/src/wxmac/src/mac/wx_mnuit.cc index de77be36f9..daadadf6f0 100644 --- a/src/wxmac/src/mac/wx_mnuit.cc +++ b/src/wxmac/src/mac/wx_mnuit.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_panel.cc b/src/wxmac/src/mac/wx_panel.cc index e71e95a212..26ba9240d8 100644 --- a/src/wxmac/src/mac/wx_panel.cc +++ b/src/wxmac/src/mac/wx_panel.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_print.cc b/src/wxmac/src/mac/wx_print.cc index 5218967362..dafda588af 100644 --- a/src/wxmac/src/mac/wx_print.cc +++ b/src/wxmac/src/mac/wx_print.cc @@ -4,7 +4,7 @@ * Author: Lj Birk (original msw by Julian Smart * Created: 1995 * Updated: October 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh */ diff --git a/src/wxmac/src/mac/wx_rbox.cc b/src/wxmac/src/mac/wx_rbox.cc index a828efe069..00f7cf72cc 100644 --- a/src/wxmac/src/mac/wx_rbox.cc +++ b/src/wxmac/src/mac/wx_rbox.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_rbut.cc b/src/wxmac/src/mac/wx_rbut.cc index 37980dcda0..bd4eccca54 100644 --- a/src/wxmac/src/mac/wx_rbut.cc +++ b/src/wxmac/src/mac/wx_rbut.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_sbar.cc b/src/wxmac/src/mac/wx_sbar.cc index 83b5fe7514..1603e75698 100644 --- a/src/wxmac/src/mac/wx_sbar.cc +++ b/src/wxmac/src/mac/wx_sbar.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_screen.cc b/src/wxmac/src/mac/wx_screen.cc index 3f75c1880f..c09cfb7709 100644 --- a/src/wxmac/src/mac/wx_screen.cc +++ b/src/wxmac/src/mac/wx_screen.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_slidr.cc b/src/wxmac/src/mac/wx_slidr.cc index 0507545ebf..b8edfb5cad 100644 --- a/src/wxmac/src/mac/wx_slidr.cc +++ b/src/wxmac/src/mac/wx_slidr.cc @@ -4,7 +4,7 @@ * Author: Cecil Coupe * Created: 1995 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. */ diff --git a/src/wxmac/src/mac/wx_tabc.cc b/src/wxmac/src/mac/wx_tabc.cc index 2cf0397b06..10d97b0e73 100644 --- a/src/wxmac/src/mac/wx_tabc.cc +++ b/src/wxmac/src/mac/wx_tabc.cc @@ -3,7 +3,7 @@ // Purpose: Panel item tab choice implementation (Macintosh version) // Author: Matthew // Created: 2002 -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 2002, PLT /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/src/mac/wx_win.cc b/src/wxmac/src/mac/wx_win.cc index 06cb033cf7..20b6c6bf76 100644 --- a/src/wxmac/src/mac/wx_win.cc +++ b/src/wxmac/src/mac/wx_win.cc @@ -4,7 +4,7 @@ // Author: Bill Hale // Created: 1994 // Updated: -// Copyright: (c) 2004-2008 PLT Scheme Inc. +// Copyright: (c) 2004-2009 PLT Scheme Inc. // Copyright: (c) 1993-94, AIAI, University of Edinburgh. All Rights Reserved. /////////////////////////////////////////////////////////////////////////////// diff --git a/src/wxmac/utils/image/src/wx_image.cc b/src/wxmac/utils/image/src/wx_image.cc index 921f14fe17..32277c4307 100644 --- a/src/wxmac/utils/image/src/wx_image.cc +++ b/src/wxmac/utils/image/src/wx_image.cc @@ -3,7 +3,7 @@ * Purpose: * * wxWindows 1.50 - * Copyright (c) 2004-2008 PLT Scheme Inc. + * Copyright (c) 2004-2009 PLT Scheme Inc. * Copyright (c) 1993 Artificial Intelligence Applications Institute, * The University of Edinburgh * diff --git a/src/wxmac/utils/image/src/wx_image.h b/src/wxmac/utils/image/src/wx_image.h index 2031d09f38..e33348e8b7 100644 --- a/src/wxmac/utils/image/src/wx_image.h +++ b/src/wxmac/utils/image/src/wx_image.h @@ -3,7 +3,7 @@ * Purpose: * * wxWindows 1.50 - * Copyright (c) 2004-2008 PLT Scheme Inc. + * Copyright (c) 2004-2009 PLT Scheme Inc. * Copyright (c) 1993 Artificial Intelligence Applications Institute, * The University of Edinburgh * diff --git a/src/wxmac/utils/image/src/wx_imgx.h b/src/wxmac/utils/image/src/wx_imgx.h index 6ec914fa7c..3fbfa3d31f 100644 --- a/src/wxmac/utils/image/src/wx_imgx.h +++ b/src/wxmac/utils/image/src/wx_imgx.h @@ -3,7 +3,7 @@ * Purpose: * * wxWindows 1.50 - * Copyright (c) 2004-2008 PLT Scheme Inc. + * Copyright (c) 2004-2009 PLT Scheme Inc. * Copyright (c) 1993 Artificial Intelligence Applications Institute, * The University of Edinburgh * diff --git a/src/wxwindow/include/base/common.h b/src/wxwindow/include/base/common.h index ff4dee9527..513ee801b5 100644 --- a/src/wxwindow/include/base/common.h +++ b/src/wxwindow/include/base/common.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_buttn.h b/src/wxwindow/include/base/wb_buttn.h index efb0646556..003e8ceb8d 100644 --- a/src/wxwindow/include/base/wb_buttn.h +++ b/src/wxwindow/include/base/wb_buttn.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_canvs.h b/src/wxwindow/include/base/wb_canvs.h index b2ae2fb997..edc68d02da 100644 --- a/src/wxwindow/include/base/wb_canvs.h +++ b/src/wxwindow/include/base/wb_canvs.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_check.h b/src/wxwindow/include/base/wb_check.h index e438005ebf..987af3e1c9 100644 --- a/src/wxwindow/include/base/wb_check.h +++ b/src/wxwindow/include/base/wb_check.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_choic.h b/src/wxwindow/include/base/wb_choic.h index 16cb7a2f71..1e6e150ae9 100644 --- a/src/wxwindow/include/base/wb_choic.h +++ b/src/wxwindow/include/base/wb_choic.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_cmdlg.h b/src/wxwindow/include/base/wb_cmdlg.h index b90ef29795..706176264a 100644 --- a/src/wxwindow/include/base/wb_cmdlg.h +++ b/src/wxwindow/include/base/wb_cmdlg.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1995 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Julian Smart * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_dc.h b/src/wxwindow/include/base/wb_dc.h index a77bdd8b2d..3726526c94 100644 --- a/src/wxwindow/include/base/wb_dc.h +++ b/src/wxwindow/include/base/wb_dc.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_dccan.h b/src/wxwindow/include/base/wb_dccan.h index f202af28e3..14475d1c9e 100644 --- a/src/wxwindow/include/base/wb_dccan.h +++ b/src/wxwindow/include/base/wb_dccan.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_dcmem.h b/src/wxwindow/include/base/wb_dcmem.h index 8ee29ac82d..fad77d937b 100644 --- a/src/wxwindow/include/base/wb_dcmem.h +++ b/src/wxwindow/include/base/wb_dcmem.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_dialg.h b/src/wxwindow/include/base/wb_dialg.h index 14fdfb0f26..c4cbbe5b54 100644 --- a/src/wxwindow/include/base/wb_dialg.h +++ b/src/wxwindow/include/base/wb_dialg.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_frame.h b/src/wxwindow/include/base/wb_frame.h index b75da31151..d057b5b181 100644 --- a/src/wxwindow/include/base/wb_frame.h +++ b/src/wxwindow/include/base/wb_frame.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_gauge.h b/src/wxwindow/include/base/wb_gauge.h index fd40d9fd2d..98eeb8105e 100644 --- a/src/wxwindow/include/base/wb_gauge.h +++ b/src/wxwindow/include/base/wb_gauge.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_gdi.h b/src/wxwindow/include/base/wb_gdi.h index 33f90d12bf..697f72f8e3 100644 --- a/src/wxwindow/include/base/wb_gdi.h +++ b/src/wxwindow/include/base/wb_gdi.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_item.h b/src/wxwindow/include/base/wb_item.h index 8d70ad107f..da263c7b35 100644 --- a/src/wxwindow/include/base/wb_item.h +++ b/src/wxwindow/include/base/wb_item.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_lbox.h b/src/wxwindow/include/base/wb_lbox.h index 1e483676fe..06f76f51ab 100644 --- a/src/wxwindow/include/base/wb_lbox.h +++ b/src/wxwindow/include/base/wb_lbox.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_main.h b/src/wxwindow/include/base/wb_main.h index 20771adfc1..fdc154349f 100644 --- a/src/wxwindow/include/base/wb_main.h +++ b/src/wxwindow/include/base/wb_main.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_menu.h b/src/wxwindow/include/base/wb_menu.h index 2b22100d84..dc8eb81ad8 100644 --- a/src/wxwindow/include/base/wb_menu.h +++ b/src/wxwindow/include/base/wb_menu.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_messg.h b/src/wxwindow/include/base/wb_messg.h index eb24802003..a2e4240461 100644 --- a/src/wxwindow/include/base/wb_messg.h +++ b/src/wxwindow/include/base/wb_messg.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_mf.h b/src/wxwindow/include/base/wb_mf.h index 65765cd593..20ccd31db0 100644 --- a/src/wxwindow/include/base/wb_mf.h +++ b/src/wxwindow/include/base/wb_mf.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_mnuit.h b/src/wxwindow/include/base/wb_mnuit.h index 63ae8aec4b..c6a386e05b 100644 --- a/src/wxwindow/include/base/wb_mnuit.h +++ b/src/wxwindow/include/base/wb_mnuit.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_panel.h b/src/wxwindow/include/base/wb_panel.h index 855b9b0f3b..a0d598fd49 100644 --- a/src/wxwindow/include/base/wb_panel.h +++ b/src/wxwindow/include/base/wb_panel.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_rbox.h b/src/wxwindow/include/base/wb_rbox.h index 3accfb5337..891411bdad 100644 --- a/src/wxwindow/include/base/wb_rbox.h +++ b/src/wxwindow/include/base/wb_rbox.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_slidr.h b/src/wxwindow/include/base/wb_slidr.h index c2ff286dc5..abfcf782e7 100644 --- a/src/wxwindow/include/base/wb_slidr.h +++ b/src/wxwindow/include/base/wb_slidr.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_timer.h b/src/wxwindow/include/base/wb_timer.h index 70371dc15b..0a8b0cf610 100644 --- a/src/wxwindow/include/base/wb_timer.h +++ b/src/wxwindow/include/base/wb_timer.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wb_win.h b/src/wxwindow/include/base/wb_win.h index 3b572bb40e..c013a875df 100644 --- a/src/wxwindow/include/base/wb_win.h +++ b/src/wxwindow/include/base/wb_win.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wx.h b/src/wxwindow/include/base/wx.h index b090eb0ab5..2a34759a61 100644 --- a/src/wxwindow/include/base/wx.h +++ b/src/wxwindow/include/base/wx.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wx_obj.h b/src/wxwindow/include/base/wx_obj.h index 1e0666e339..fb3aadac49 100644 --- a/src/wxwindow/include/base/wx_obj.h +++ b/src/wxwindow/include/base/wx_obj.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wx_print.h b/src/wxwindow/include/base/wx_print.h index c81c38d3c2..8c99204725 100644 --- a/src/wxwindow/include/base/wx_print.h +++ b/src/wxwindow/include/base/wx_print.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1995 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wx_setup.h b/src/wxwindow/include/base/wx_setup.h index 8567eeb1c4..1332849cd2 100644 --- a/src/wxwindow/include/base/wx_setup.h +++ b/src/wxwindow/include/base/wx_setup.h @@ -5,7 +5,7 @@ * Author: Julian Smart * Created: 1993 * Updated: June 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wx_stdev.h b/src/wxwindow/include/base/wx_stdev.h index 6d9343b4b6..beed1a4df8 100644 --- a/src/wxwindow/include/base/wx_stdev.h +++ b/src/wxwindow/include/base/wx_stdev.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wx_sysev.h b/src/wxwindow/include/base/wx_sysev.h index 856bd2ce7b..d98a1b8a7a 100644 --- a/src/wxwindow/include/base/wx_sysev.h +++ b/src/wxwindow/include/base/wx_sysev.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wx_types.h b/src/wxwindow/include/base/wx_types.h index 7fdcad6e22..5e8337c935 100644 --- a/src/wxwindow/include/base/wx_types.h +++ b/src/wxwindow/include/base/wx_types.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/base/wx_utils.h b/src/wxwindow/include/base/wx_utils.h index 1603d7689c..c8ac0097f8 100644 --- a/src/wxwindow/include/base/wx_utils.h +++ b/src/wxwindow/include/base/wx_utils.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_buttn.h b/src/wxwindow/include/msw/wx_buttn.h index de54059d26..7b55924a79 100644 --- a/src/wxwindow/include/msw/wx_buttn.h +++ b/src/wxwindow/include/msw/wx_buttn.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_canvs.h b/src/wxwindow/include/msw/wx_canvs.h index b114241887..aabd567c55 100644 --- a/src/wxwindow/include/msw/wx_canvs.h +++ b/src/wxwindow/include/msw/wx_canvs.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_check.h b/src/wxwindow/include/msw/wx_check.h index 4cebf4d760..0e4e9338e0 100644 --- a/src/wxwindow/include/msw/wx_check.h +++ b/src/wxwindow/include/msw/wx_check.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_choic.h b/src/wxwindow/include/msw/wx_choic.h index 9bbe84d56a..8879f21c09 100644 --- a/src/wxwindow/include/msw/wx_choic.h +++ b/src/wxwindow/include/msw/wx_choic.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_clipb.h b/src/wxwindow/include/msw/wx_clipb.h index b5fa58c86f..45f2a68c1d 100644 --- a/src/wxwindow/include/msw/wx_clipb.h +++ b/src/wxwindow/include/msw/wx_clipb.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_cmdlg.h b/src/wxwindow/include/msw/wx_cmdlg.h index 157e08db65..6e6d5ea82a 100644 --- a/src/wxwindow/include/msw/wx_cmdlg.h +++ b/src/wxwindow/include/msw/wx_cmdlg.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1995 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Julian Smart * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_dc.h b/src/wxwindow/include/msw/wx_dc.h index 78c913848c..4b5334c0a7 100644 --- a/src/wxwindow/include/msw/wx_dc.h +++ b/src/wxwindow/include/msw/wx_dc.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_dccan.h b/src/wxwindow/include/msw/wx_dccan.h index ae65e4a977..1ebd1f2fbc 100644 --- a/src/wxwindow/include/msw/wx_dccan.h +++ b/src/wxwindow/include/msw/wx_dccan.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_dcmem.h b/src/wxwindow/include/msw/wx_dcmem.h index 5367563911..297d09eacf 100644 --- a/src/wxwindow/include/msw/wx_dcmem.h +++ b/src/wxwindow/include/msw/wx_dcmem.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_dialg.h b/src/wxwindow/include/msw/wx_dialg.h index 6fb7b40190..21701f31b2 100644 --- a/src/wxwindow/include/msw/wx_dialg.h +++ b/src/wxwindow/include/msw/wx_dialg.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_frame.h b/src/wxwindow/include/msw/wx_frame.h index b02ceaaa26..b6aca69a94 100644 --- a/src/wxwindow/include/msw/wx_frame.h +++ b/src/wxwindow/include/msw/wx_frame.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_gauge.h b/src/wxwindow/include/msw/wx_gauge.h index ae201b7e49..e68f2c24be 100644 --- a/src/wxwindow/include/msw/wx_gauge.h +++ b/src/wxwindow/include/msw/wx_gauge.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_gbox.h b/src/wxwindow/include/msw/wx_gbox.h index 07160acac9..923512dd28 100644 --- a/src/wxwindow/include/msw/wx_gbox.h +++ b/src/wxwindow/include/msw/wx_gbox.h @@ -3,7 +3,7 @@ * Purpose: Group box item * Author: Matthew * Created: 2003 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 2003, PLT */ diff --git a/src/wxwindow/include/msw/wx_gdi.h b/src/wxwindow/include/msw/wx_gdi.h index b987a24c06..a14783675e 100644 --- a/src/wxwindow/include/msw/wx_gdi.h +++ b/src/wxwindow/include/msw/wx_gdi.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_item.h b/src/wxwindow/include/msw/wx_item.h index 48c4cf2561..7c792b1dcd 100644 --- a/src/wxwindow/include/msw/wx_item.h +++ b/src/wxwindow/include/msw/wx_item.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_itemp.h b/src/wxwindow/include/msw/wx_itemp.h index 9cf1adf02a..b5a5ac1897 100644 --- a/src/wxwindow/include/msw/wx_itemp.h +++ b/src/wxwindow/include/msw/wx_itemp.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_lbox.h b/src/wxwindow/include/msw/wx_lbox.h index 8327054ec6..5f1ae264ef 100644 --- a/src/wxwindow/include/msw/wx_lbox.h +++ b/src/wxwindow/include/msw/wx_lbox.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_main.h b/src/wxwindow/include/msw/wx_main.h index e500925d26..15f0230219 100644 --- a/src/wxwindow/include/msw/wx_main.h +++ b/src/wxwindow/include/msw/wx_main.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_menu.h b/src/wxwindow/include/msw/wx_menu.h index ffda5b2f34..bf3c2fed39 100644 --- a/src/wxwindow/include/msw/wx_menu.h +++ b/src/wxwindow/include/msw/wx_menu.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_messg.h b/src/wxwindow/include/msw/wx_messg.h index 89781dea3a..2bae604f11 100644 --- a/src/wxwindow/include/msw/wx_messg.h +++ b/src/wxwindow/include/msw/wx_messg.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_mf.h b/src/wxwindow/include/msw/wx_mf.h index 09744e812b..eeb6bff440 100644 --- a/src/wxwindow/include/msw/wx_mf.h +++ b/src/wxwindow/include/msw/wx_mf.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_mnuit.h b/src/wxwindow/include/msw/wx_mnuit.h index a1a7a5e6d5..9ba408f4b1 100644 --- a/src/wxwindow/include/msw/wx_mnuit.h +++ b/src/wxwindow/include/msw/wx_mnuit.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_panel.h b/src/wxwindow/include/msw/wx_panel.h index 45ae3d7e05..aa83daa611 100644 --- a/src/wxwindow/include/msw/wx_panel.h +++ b/src/wxwindow/include/msw/wx_panel.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_privt.h b/src/wxwindow/include/msw/wx_privt.h index 3d62b5a611..fa5f7291ed 100644 --- a/src/wxwindow/include/msw/wx_privt.h +++ b/src/wxwindow/include/msw/wx_privt.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_rbox.h b/src/wxwindow/include/msw/wx_rbox.h index 3a86fd2e27..4de83e0591 100644 --- a/src/wxwindow/include/msw/wx_rbox.h +++ b/src/wxwindow/include/msw/wx_rbox.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_slidr.h b/src/wxwindow/include/msw/wx_slidr.h index 3fd2e96b74..8751b273ff 100644 --- a/src/wxwindow/include/msw/wx_slidr.h +++ b/src/wxwindow/include/msw/wx_slidr.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_tabc.h b/src/wxwindow/include/msw/wx_tabc.h index 48d3bdaf7d..90b37b7b31 100644 --- a/src/wxwindow/include/msw/wx_tabc.h +++ b/src/wxwindow/include/msw/wx_tabc.h @@ -3,7 +3,7 @@ * Purpose: Tab group panel item * Author: Matthew * Created: 2002 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 2002, PLT */ diff --git a/src/wxwindow/include/msw/wx_timer.h b/src/wxwindow/include/msw/wx_timer.h index b26406d3e1..6e3bb7bee4 100644 --- a/src/wxwindow/include/msw/wx_timer.h +++ b/src/wxwindow/include/msw/wx_timer.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wx_win.h b/src/wxwindow/include/msw/wx_win.h index 3250db976a..07c1e88b31 100644 --- a/src/wxwindow/include/msw/wx_win.h +++ b/src/wxwindow/include/msw/wx_win.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/include/msw/wximgfil.h b/src/wxwindow/include/msw/wximgfil.h index dd501a290d..b72a290f8a 100644 --- a/src/wxwindow/include/msw/wximgfil.h +++ b/src/wxwindow/include/msw/wximgfil.h @@ -3,7 +3,7 @@ * Purpose: Declaration of the Platform Independent GIF Image Class * Author: Alejandro Aguilar Sierra * Created: 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Alejandro Aguilar Sierra * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_canvs.cxx b/src/wxwindow/src/base/wb_canvs.cxx index 875412751e..9bf6cf5f39 100644 --- a/src/wxwindow/src/base/wb_canvs.cxx +++ b/src/wxwindow/src/base/wb_canvs.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_cmdlg.cxx b/src/wxwindow/src/base/wb_cmdlg.cxx index dbc9fd58ba..3cd17d2797 100644 --- a/src/wxwindow/src/base/wb_cmdlg.cxx +++ b/src/wxwindow/src/base/wb_cmdlg.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1995 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Julian Smart * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_dc.cxx b/src/wxwindow/src/base/wb_dc.cxx index 47c516409e..f409ea4a57 100644 --- a/src/wxwindow/src/base/wb_dc.cxx +++ b/src/wxwindow/src/base/wb_dc.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_dialg.cxx b/src/wxwindow/src/base/wb_dialg.cxx index cebbdb8d8b..cea6336b96 100644 --- a/src/wxwindow/src/base/wb_dialg.cxx +++ b/src/wxwindow/src/base/wb_dialg.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_frame.cxx b/src/wxwindow/src/base/wb_frame.cxx index 4ce8b70951..11292f07f5 100644 --- a/src/wxwindow/src/base/wb_frame.cxx +++ b/src/wxwindow/src/base/wb_frame.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_gdi.cxx b/src/wxwindow/src/base/wb_gdi.cxx index e37418a538..f49a3b9b44 100644 --- a/src/wxwindow/src/base/wb_gdi.cxx +++ b/src/wxwindow/src/base/wb_gdi.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_item.cxx b/src/wxwindow/src/base/wb_item.cxx index 18dbc58b31..9bef79c6e9 100644 --- a/src/wxwindow/src/base/wb_item.cxx +++ b/src/wxwindow/src/base/wb_item.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: March 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_main.cxx b/src/wxwindow/src/base/wb_main.cxx index 535dac4b8a..68a60c277e 100644 --- a/src/wxwindow/src/base/wb_main.cxx +++ b/src/wxwindow/src/base/wb_main.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_obj.cxx b/src/wxwindow/src/base/wb_obj.cxx index 619fe9582e..1340614842 100644 --- a/src/wxwindow/src/base/wb_obj.cxx +++ b/src/wxwindow/src/base/wb_obj.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_panel.cxx b/src/wxwindow/src/base/wb_panel.cxx index 7e9d60c065..3c787b2f19 100644 --- a/src/wxwindow/src/base/wb_panel.cxx +++ b/src/wxwindow/src/base/wb_panel.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_print.cxx b/src/wxwindow/src/base/wb_print.cxx index dbbc680ea9..6770fa5569 100644 --- a/src/wxwindow/src/base/wb_print.cxx +++ b/src/wxwindow/src/base/wb_print.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1995 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_stdev.cxx b/src/wxwindow/src/base/wb_stdev.cxx index ba59e57a7b..ccace11758 100644 --- a/src/wxwindow/src/base/wb_stdev.cxx +++ b/src/wxwindow/src/base/wb_stdev.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_sysev.cxx b/src/wxwindow/src/base/wb_sysev.cxx index 907321194e..324579422c 100644 --- a/src/wxwindow/src/base/wb_sysev.cxx +++ b/src/wxwindow/src/base/wb_sysev.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_timer.cxx b/src/wxwindow/src/base/wb_timer.cxx index fae27589c6..3ca7222d6a 100644 --- a/src/wxwindow/src/base/wb_timer.cxx +++ b/src/wxwindow/src/base/wb_timer.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_types.cxx b/src/wxwindow/src/base/wb_types.cxx index 92f85567f5..a00429d6fa 100644 --- a/src/wxwindow/src/base/wb_types.cxx +++ b/src/wxwindow/src/base/wb_types.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_utils.cxx b/src/wxwindow/src/base/wb_utils.cxx index b56f9bd088..63175cbfbd 100644 --- a/src/wxwindow/src/base/wb_utils.cxx +++ b/src/wxwindow/src/base/wb_utils.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/wb_win.cxx b/src/wxwindow/src/base/wb_win.cxx index 4a1e028195..be74f84c58 100644 --- a/src/wxwindow/src/base/wb_win.cxx +++ b/src/wxwindow/src/base/wb_win.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/base/xfspline.cxx b/src/wxwindow/src/base/xfspline.cxx index 2163267954..036e57a482 100644 --- a/src/wxwindow/src/base/xfspline.cxx +++ b/src/wxwindow/src/base/xfspline.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_buttn.cxx b/src/wxwindow/src/msw/wx_buttn.cxx index d7022f8dd4..452878a7bb 100644 --- a/src/wxwindow/src/msw/wx_buttn.cxx +++ b/src/wxwindow/src/msw/wx_buttn.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_canvs.cxx b/src/wxwindow/src/msw/wx_canvs.cxx index 32984d0948..584a6f8329 100644 --- a/src/wxwindow/src/msw/wx_canvs.cxx +++ b/src/wxwindow/src/msw/wx_canvs.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_check.cxx b/src/wxwindow/src/msw/wx_check.cxx index d7104e47eb..1b8672e739 100644 --- a/src/wxwindow/src/msw/wx_check.cxx +++ b/src/wxwindow/src/msw/wx_check.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_choic.cxx b/src/wxwindow/src/msw/wx_choic.cxx index e9cba31bff..1ec6e36f77 100644 --- a/src/wxwindow/src/msw/wx_choic.cxx +++ b/src/wxwindow/src/msw/wx_choic.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_clipb.cxx b/src/wxwindow/src/msw/wx_clipb.cxx index ce37eed0c8..ed7f3ad287 100644 --- a/src/wxwindow/src/msw/wx_clipb.cxx +++ b/src/wxwindow/src/msw/wx_clipb.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_cmdlg.cxx b/src/wxwindow/src/msw/wx_cmdlg.cxx index 05daf1a934..94a7e3f081 100644 --- a/src/wxwindow/src/msw/wx_cmdlg.cxx +++ b/src/wxwindow/src/msw/wx_cmdlg.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1995 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, Julian Smart * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_dc.cxx b/src/wxwindow/src/msw/wx_dc.cxx index 24af20cce8..8dbb2782ef 100644 --- a/src/wxwindow/src/msw/wx_dc.cxx +++ b/src/wxwindow/src/msw/wx_dc.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_dialg.cxx b/src/wxwindow/src/msw/wx_dialg.cxx index 601c8a0ba9..5285489286 100644 --- a/src/wxwindow/src/msw/wx_dialg.cxx +++ b/src/wxwindow/src/msw/wx_dialg.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_frame.cxx b/src/wxwindow/src/msw/wx_frame.cxx index 29208939f1..5564a6adb0 100644 --- a/src/wxwindow/src/msw/wx_frame.cxx +++ b/src/wxwindow/src/msw/wx_frame.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_gauge.cxx b/src/wxwindow/src/msw/wx_gauge.cxx index 7267256e8e..460000da77 100644 --- a/src/wxwindow/src/msw/wx_gauge.cxx +++ b/src/wxwindow/src/msw/wx_gauge.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_gbox.cxx b/src/wxwindow/src/msw/wx_gbox.cxx index 4a34174ce1..56200cda07 100644 --- a/src/wxwindow/src/msw/wx_gbox.cxx +++ b/src/wxwindow/src/msw/wx_gbox.cxx @@ -3,7 +3,7 @@ * Purpose: Group box item implementation * Author: Matthew Flatt * Created: 2003 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 2003, PLT */ diff --git a/src/wxwindow/src/msw/wx_gdi.cxx b/src/wxwindow/src/msw/wx_gdi.cxx index af4b3c18b2..3934c1cecf 100644 --- a/src/wxwindow/src/msw/wx_gdi.cxx +++ b/src/wxwindow/src/msw/wx_gdi.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_item.cxx b/src/wxwindow/src/msw/wx_item.cxx index 73d3949e1f..7dbed075d1 100644 --- a/src/wxwindow/src/msw/wx_item.cxx +++ b/src/wxwindow/src/msw/wx_item.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_lbox.cxx b/src/wxwindow/src/msw/wx_lbox.cxx index d0852c2da0..3c153d042f 100644 --- a/src/wxwindow/src/msw/wx_lbox.cxx +++ b/src/wxwindow/src/msw/wx_lbox.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_main.cxx b/src/wxwindow/src/msw/wx_main.cxx index 6967df3146..51bdbbdc1c 100644 --- a/src/wxwindow/src/msw/wx_main.cxx +++ b/src/wxwindow/src/msw/wx_main.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_menu.cxx b/src/wxwindow/src/msw/wx_menu.cxx index fa16987508..1c85bc0937 100644 --- a/src/wxwindow/src/msw/wx_menu.cxx +++ b/src/wxwindow/src/msw/wx_menu.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_messg.cxx b/src/wxwindow/src/msw/wx_messg.cxx index ee21a04de3..b3acb1b833 100644 --- a/src/wxwindow/src/msw/wx_messg.cxx +++ b/src/wxwindow/src/msw/wx_messg.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_panel.cxx b/src/wxwindow/src/msw/wx_panel.cxx index e124d49113..487e6400e2 100644 --- a/src/wxwindow/src/msw/wx_panel.cxx +++ b/src/wxwindow/src/msw/wx_panel.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_pdf.cxx b/src/wxwindow/src/msw/wx_pdf.cxx index bd6bee724b..9ae86745c8 100644 --- a/src/wxwindow/src/msw/wx_pdf.cxx +++ b/src/wxwindow/src/msw/wx_pdf.cxx @@ -1,6 +1,6 @@ /* - Copyright (c) 2004-2008 PLT Scheme Inc. + Copyright (c) 2004-2009 PLT Scheme Inc. Copyright (c) 1997-02 PLT (Matthew Flatt) This file exists because of a problem in Windows: when diff --git a/src/wxwindow/src/msw/wx_rbox.cxx b/src/wxwindow/src/msw/wx_rbox.cxx index a4c40e6311..08ced8f325 100644 --- a/src/wxwindow/src/msw/wx_rbox.cxx +++ b/src/wxwindow/src/msw/wx_rbox.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_slidr.cxx b/src/wxwindow/src/msw/wx_slidr.cxx index 147e781001..44e655fd34 100644 --- a/src/wxwindow/src/msw/wx_slidr.cxx +++ b/src/wxwindow/src/msw/wx_slidr.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: April 1995 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1995, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_tabc.cxx b/src/wxwindow/src/msw/wx_tabc.cxx index a6a05e2cd2..ec3e51eee5 100644 --- a/src/wxwindow/src/msw/wx_tabc.cxx +++ b/src/wxwindow/src/msw/wx_tabc.cxx @@ -3,7 +3,7 @@ * Purpose: Tab choice implementation * Author: Matthew * Created: 2002 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 2002, PLT */ diff --git a/src/wxwindow/src/msw/wx_timer.cxx b/src/wxwindow/src/msw/wx_timer.cxx index f19733595f..37c1ae3ae4 100644 --- a/src/wxwindow/src/msw/wx_timer.cxx +++ b/src/wxwindow/src/msw/wx_timer.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_utils.cxx b/src/wxwindow/src/msw/wx_utils.cxx index 0f951013ee..31779dfadf 100644 --- a/src/wxwindow/src/msw/wx_utils.cxx +++ b/src/wxwindow/src/msw/wx_utils.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxwindow/src/msw/wx_win.cxx b/src/wxwindow/src/msw/wx_win.cxx index 478ce3f2b3..7f2a7790f7 100644 --- a/src/wxwindow/src/msw/wx_win.cxx +++ b/src/wxwindow/src/msw/wx_win.cxx @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh * * Renovated by Matthew for MrEd, 1995-2000 diff --git a/src/wxxt/src/Application/AppMain.cc b/src/wxxt/src/Application/AppMain.cc index edbcee5042..64672789b4 100644 --- a/src/wxxt/src/Application/AppMain.cc +++ b/src/wxxt/src/Application/AppMain.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Application/AppMain.h b/src/wxxt/src/Application/AppMain.h index 2d6a6bb766..f9c6b96ed4 100644 --- a/src/wxxt/src/Application/AppMain.h +++ b/src/wxxt/src/Application/AppMain.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Application/GlobalData.cc b/src/wxxt/src/Application/GlobalData.cc index 56c7227673..64c7efa825 100644 --- a/src/wxxt/src/Application/GlobalData.cc +++ b/src/wxxt/src/Application/GlobalData.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Application/GlobalData.h b/src/wxxt/src/Application/GlobalData.h index 0f084da508..700dbe5b9d 100644 --- a/src/wxxt/src/Application/GlobalData.h +++ b/src/wxxt/src/Application/GlobalData.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DataStructures/Object.cc b/src/wxxt/src/DataStructures/Object.cc index 39983b97f1..e2dfdbf228 100644 --- a/src/wxxt/src/DataStructures/Object.cc +++ b/src/wxxt/src/DataStructures/Object.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem, Julian Smart and Arthur Seaton * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian, Arthur) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DataStructures/Object.h b/src/wxxt/src/DataStructures/Object.h index a6a2561fb2..70ce663ace 100644 --- a/src/wxxt/src/DataStructures/Object.h +++ b/src/wxxt/src/DataStructures/Object.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem, Julian Smart and Arthur Seaton * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian, Arthur) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DataStructures/TypeTree.cc b/src/wxxt/src/DataStructures/TypeTree.cc index 8c21f116ad..fa208ff4d2 100644 --- a/src/wxxt/src/DataStructures/TypeTree.cc +++ b/src/wxxt/src/DataStructures/TypeTree.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DataStructures/TypeTree.h b/src/wxxt/src/DataStructures/TypeTree.h index 7b6496180f..997afb3e0e 100644 --- a/src/wxxt/src/DataStructures/TypeTree.h +++ b/src/wxxt/src/DataStructures/TypeTree.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DeviceContexts/DC.cc b/src/wxxt/src/DeviceContexts/DC.cc index f0eaa69388..53b45457e5 100644 --- a/src/wxxt/src/DeviceContexts/DC.cc +++ b/src/wxxt/src/DeviceContexts/DC.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DeviceContexts/DC.h b/src/wxxt/src/DeviceContexts/DC.h index 27d71ebc10..a2839adc0e 100644 --- a/src/wxxt/src/DeviceContexts/DC.h +++ b/src/wxxt/src/DeviceContexts/DC.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DeviceContexts/MemoryDC.cc b/src/wxxt/src/DeviceContexts/MemoryDC.cc index f011ac2949..34904409f9 100644 --- a/src/wxxt/src/DeviceContexts/MemoryDC.cc +++ b/src/wxxt/src/DeviceContexts/MemoryDC.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DeviceContexts/MemoryDC.h b/src/wxxt/src/DeviceContexts/MemoryDC.h index 3981cbb992..91c8e24d93 100644 --- a/src/wxxt/src/DeviceContexts/MemoryDC.h +++ b/src/wxxt/src/DeviceContexts/MemoryDC.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DeviceContexts/WindowDC.cc b/src/wxxt/src/DeviceContexts/WindowDC.cc index eac2053b55..362577fd97 100644 --- a/src/wxxt/src/DeviceContexts/WindowDC.cc +++ b/src/wxxt/src/DeviceContexts/WindowDC.cc @@ -5,7 +5,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/DeviceContexts/WindowDC.h b/src/wxxt/src/DeviceContexts/WindowDC.h index f39b41c658..ba5ff56dc6 100644 --- a/src/wxxt/src/DeviceContexts/WindowDC.h +++ b/src/wxxt/src/DeviceContexts/WindowDC.h @@ -5,7 +5,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Dialogs/Dialogs.h b/src/wxxt/src/Dialogs/Dialogs.h index 9b71b004c0..a56e3cf5e3 100644 --- a/src/wxxt/src/Dialogs/Dialogs.h +++ b/src/wxxt/src/Dialogs/Dialogs.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Dialogs/FileDialog.cc b/src/wxxt/src/Dialogs/FileDialog.cc index a05ec4f77a..bd405a7ce4 100644 --- a/src/wxxt/src/Dialogs/FileDialog.cc +++ b/src/wxxt/src/Dialogs/FileDialog.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Dialogs/MessageBox.cc b/src/wxxt/src/Dialogs/MessageBox.cc index 8e4ccf11e9..636ed3af6b 100644 --- a/src/wxxt/src/Dialogs/MessageBox.cc +++ b/src/wxxt/src/Dialogs/MessageBox.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/EventHandling/EvtHandler.cc b/src/wxxt/src/EventHandling/EvtHandler.cc index 6e21db5164..3342ceb831 100644 --- a/src/wxxt/src/EventHandling/EvtHandler.cc +++ b/src/wxxt/src/EventHandling/EvtHandler.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/EventHandling/EvtHandler.h b/src/wxxt/src/EventHandling/EvtHandler.h index ff65736345..74c2a1bc84 100644 --- a/src/wxxt/src/EventHandling/EvtHandler.h +++ b/src/wxxt/src/EventHandling/EvtHandler.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/EventHandling/wb_stdev.cc b/src/wxxt/src/EventHandling/wb_stdev.cc index eddcdbe05a..4c0fc2fec5 100644 --- a/src/wxxt/src/EventHandling/wb_stdev.cc +++ b/src/wxxt/src/EventHandling/wb_stdev.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxxt/src/EventHandling/wb_sysev.cc b/src/wxxt/src/EventHandling/wb_sysev.cc index 31ba42cff3..80df74a06f 100644 --- a/src/wxxt/src/EventHandling/wb_sysev.cc +++ b/src/wxxt/src/EventHandling/wb_sysev.cc @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxxt/src/EventHandling/wx_stdev.h b/src/wxxt/src/EventHandling/wx_stdev.h index 4f23b54dea..7e9637ff4e 100644 --- a/src/wxxt/src/EventHandling/wx_stdev.h +++ b/src/wxxt/src/EventHandling/wx_stdev.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxxt/src/EventHandling/wx_sysev.h b/src/wxxt/src/EventHandling/wx_sysev.h index 590ad23e6a..40d97b4986 100644 --- a/src/wxxt/src/EventHandling/wx_sysev.h +++ b/src/wxxt/src/EventHandling/wx_sysev.h @@ -4,7 +4,7 @@ * Author: Julian Smart * Created: 1993 * Updated: - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxxt/src/GDI-Classes/Bitmap.cc b/src/wxxt/src/GDI-Classes/Bitmap.cc index 79095d5193..553b3cdcc5 100644 --- a/src/wxxt/src/GDI-Classes/Bitmap.cc +++ b/src/wxxt/src/GDI-Classes/Bitmap.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/GDI-Classes/Bitmap.h b/src/wxxt/src/GDI-Classes/Bitmap.h index f30c52e499..3966b5a923 100644 --- a/src/wxxt/src/GDI-Classes/Bitmap.h +++ b/src/wxxt/src/GDI-Classes/Bitmap.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/GDI-Classes/Colour.cc b/src/wxxt/src/GDI-Classes/Colour.cc index 1f114bdf51..31b189dc45 100644 --- a/src/wxxt/src/GDI-Classes/Colour.cc +++ b/src/wxxt/src/GDI-Classes/Colour.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/GDI-Classes/Colour.h b/src/wxxt/src/GDI-Classes/Colour.h index 97fffc5eb4..c66c89e227 100644 --- a/src/wxxt/src/GDI-Classes/Colour.h +++ b/src/wxxt/src/GDI-Classes/Colour.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/GDI-Classes/Font.cc b/src/wxxt/src/GDI-Classes/Font.cc index 4043a752c8..7662a363ae 100644 --- a/src/wxxt/src/GDI-Classes/Font.cc +++ b/src/wxxt/src/GDI-Classes/Font.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/GDI-Classes/Font.h b/src/wxxt/src/GDI-Classes/Font.h index b36dd7086b..d1636d1caa 100644 --- a/src/wxxt/src/GDI-Classes/Font.h +++ b/src/wxxt/src/GDI-Classes/Font.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/GDI-Classes/Pen+Brush.cc b/src/wxxt/src/GDI-Classes/Pen+Brush.cc index ab2a830e2a..671393ab78 100644 --- a/src/wxxt/src/GDI-Classes/Pen+Brush.cc +++ b/src/wxxt/src/GDI-Classes/Pen+Brush.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/GDI-Classes/Pen+Brush.h b/src/wxxt/src/GDI-Classes/Pen+Brush.h index 566cfb9664..46ac5f3a94 100644 --- a/src/wxxt/src/GDI-Classes/Pen+Brush.h +++ b/src/wxxt/src/GDI-Classes/Pen+Brush.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Misc/Clipboard.cc b/src/wxxt/src/Misc/Clipboard.cc index e6d218c252..1b679284fb 100644 --- a/src/wxxt/src/Misc/Clipboard.cc +++ b/src/wxxt/src/Misc/Clipboard.cc @@ -4,7 +4,7 @@ * Author: Julian Smart and Matthew Flatt * Created: 1993 * Updated: August 1994 - * Copyright: (c) 2004-2008 PLT Scheme Inc. + * Copyright: (c) 2004-2009 PLT Scheme Inc. * Copyright: (c) 1993, AIAI, University of Edinburgh */ diff --git a/src/wxxt/src/Misc/Timer.cc b/src/wxxt/src/Misc/Timer.cc index 32c9aa3efe..1f2c94d0d4 100644 --- a/src/wxxt/src/Misc/Timer.cc +++ b/src/wxxt/src/Misc/Timer.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Misc/Timer.h b/src/wxxt/src/Misc/Timer.h index 0f677f19f4..69783f2f60 100644 --- a/src/wxxt/src/Misc/Timer.h +++ b/src/wxxt/src/Misc/Timer.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Application.cc b/src/wxxt/src/Utilities/Application.cc index 53136bc475..a44ee02e33 100644 --- a/src/wxxt/src/Utilities/Application.cc +++ b/src/wxxt/src/Utilities/Application.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Assert.cc b/src/wxxt/src/Utilities/Assert.cc index 4751fa481b..3babb9f03f 100644 --- a/src/wxxt/src/Utilities/Assert.cc +++ b/src/wxxt/src/Utilities/Assert.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/BusyCursor.cc b/src/wxxt/src/Utilities/BusyCursor.cc index 0fad7ea538..0942aa6fc8 100644 --- a/src/wxxt/src/Utilities/BusyCursor.cc +++ b/src/wxxt/src/Utilities/BusyCursor.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Date+Time.cc b/src/wxxt/src/Utilities/Date+Time.cc index 8eaa3badcc..ac2ed16295 100644 --- a/src/wxxt/src/Utilities/Date+Time.cc +++ b/src/wxxt/src/Utilities/Date+Time.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Directory.cc b/src/wxxt/src/Utilities/Directory.cc index 347d0ca51c..681a5e3317 100644 --- a/src/wxxt/src/Utilities/Directory.cc +++ b/src/wxxt/src/Utilities/Directory.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Error.cc b/src/wxxt/src/Utilities/Error.cc index 43b6778360..4e431b96bb 100644 --- a/src/wxxt/src/Utilities/Error.cc +++ b/src/wxxt/src/Utilities/Error.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/GDI.cc b/src/wxxt/src/Utilities/GDI.cc index 3599b73794..f0e59d6d4d 100644 --- a/src/wxxt/src/Utilities/GDI.cc +++ b/src/wxxt/src/Utilities/GDI.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Home.cc b/src/wxxt/src/Utilities/Home.cc index e0f2b1cb45..5004f213f6 100644 --- a/src/wxxt/src/Utilities/Home.cc +++ b/src/wxxt/src/Utilities/Home.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Misc.cc b/src/wxxt/src/Utilities/Misc.cc index 9b292e76de..9b8f54e0b6 100644 --- a/src/wxxt/src/Utilities/Misc.cc +++ b/src/wxxt/src/Utilities/Misc.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Net.c b/src/wxxt/src/Utilities/Net.c index ea7bac282e..e66ef7dd2b 100644 --- a/src/wxxt/src/Utilities/Net.c +++ b/src/wxxt/src/Utilities/Net.c @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Path.cc b/src/wxxt/src/Utilities/Path.cc index 00bbb1ca5d..b9ade03533 100644 --- a/src/wxxt/src/Utilities/Path.cc +++ b/src/wxxt/src/Utilities/Path.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Resources.cc b/src/wxxt/src/Utilities/Resources.cc index 00ba77aa84..2f083ff6db 100644 --- a/src/wxxt/src/Utilities/Resources.cc +++ b/src/wxxt/src/Utilities/Resources.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/String.cc b/src/wxxt/src/Utilities/String.cc index b054bfbdc3..e9a5c11197 100644 --- a/src/wxxt/src/Utilities/String.cc +++ b/src/wxxt/src/Utilities/String.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/TempFile.cc b/src/wxxt/src/Utilities/TempFile.cc index 0c7e46fda8..145d0be7f0 100644 --- a/src/wxxt/src/Utilities/TempFile.cc +++ b/src/wxxt/src/Utilities/TempFile.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Utilities/Utilities.h b/src/wxxt/src/Utilities/Utilities.h index 2e7df1585d..7b044fd116 100644 --- a/src/wxxt/src/Utilities/Utilities.h +++ b/src/wxxt/src/Utilities/Utilities.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Button.cc b/src/wxxt/src/Windows/Button.cc index c6e8aeeed8..3a4ef22df4 100644 --- a/src/wxxt/src/Windows/Button.cc +++ b/src/wxxt/src/Windows/Button.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Button.h b/src/wxxt/src/Windows/Button.h index 8a216ffbbf..ffe8b38311 100644 --- a/src/wxxt/src/Windows/Button.h +++ b/src/wxxt/src/Windows/Button.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Canvas.cc b/src/wxxt/src/Windows/Canvas.cc index 3f08e8b938..0ec786c355 100644 --- a/src/wxxt/src/Windows/Canvas.cc +++ b/src/wxxt/src/Windows/Canvas.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Canvas.h b/src/wxxt/src/Windows/Canvas.h index f20be21526..810a50356c 100644 --- a/src/wxxt/src/Windows/Canvas.h +++ b/src/wxxt/src/Windows/Canvas.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/CheckBox.cc b/src/wxxt/src/Windows/CheckBox.cc index f0c4dbaee7..7015ddc5e2 100644 --- a/src/wxxt/src/Windows/CheckBox.cc +++ b/src/wxxt/src/Windows/CheckBox.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/CheckBox.h b/src/wxxt/src/Windows/CheckBox.h index c36e4d4c2a..45363d47e7 100644 --- a/src/wxxt/src/Windows/CheckBox.h +++ b/src/wxxt/src/Windows/CheckBox.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Choice.cc b/src/wxxt/src/Windows/Choice.cc index c52f206198..c5918f098a 100644 --- a/src/wxxt/src/Windows/Choice.cc +++ b/src/wxxt/src/Windows/Choice.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Choice.h b/src/wxxt/src/Windows/Choice.h index f2496ea2ee..f46d33d598 100644 --- a/src/wxxt/src/Windows/Choice.h +++ b/src/wxxt/src/Windows/Choice.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/DialogBox.cc b/src/wxxt/src/Windows/DialogBox.cc index 306b9709bc..22c128366d 100644 --- a/src/wxxt/src/Windows/DialogBox.cc +++ b/src/wxxt/src/Windows/DialogBox.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/DialogBox.h b/src/wxxt/src/Windows/DialogBox.h index eeec11e609..8394452d33 100644 --- a/src/wxxt/src/Windows/DialogBox.h +++ b/src/wxxt/src/Windows/DialogBox.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Frame.cc b/src/wxxt/src/Windows/Frame.cc index d8575f58ae..bac4c1b034 100644 --- a/src/wxxt/src/Windows/Frame.cc +++ b/src/wxxt/src/Windows/Frame.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Frame.h b/src/wxxt/src/Windows/Frame.h index 1d774310ff..fa51c14d1a 100644 --- a/src/wxxt/src/Windows/Frame.h +++ b/src/wxxt/src/Windows/Frame.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Gauge.cc b/src/wxxt/src/Windows/Gauge.cc index 69c261a244..474469eedf 100644 --- a/src/wxxt/src/Windows/Gauge.cc +++ b/src/wxxt/src/Windows/Gauge.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Gauge.h b/src/wxxt/src/Windows/Gauge.h index 125dcd8f20..41fe897a4f 100644 --- a/src/wxxt/src/Windows/Gauge.h +++ b/src/wxxt/src/Windows/Gauge.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Item.cc b/src/wxxt/src/Windows/Item.cc index fd8f1d2c48..00442a1cb8 100644 --- a/src/wxxt/src/Windows/Item.cc +++ b/src/wxxt/src/Windows/Item.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Item.h b/src/wxxt/src/Windows/Item.h index 6b18254859..64e621f95d 100644 --- a/src/wxxt/src/Windows/Item.h +++ b/src/wxxt/src/Windows/Item.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Layout.cc b/src/wxxt/src/Windows/Layout.cc index f95ba870bc..ca53889f37 100644 --- a/src/wxxt/src/Windows/Layout.cc +++ b/src/wxxt/src/Windows/Layout.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Layout.h b/src/wxxt/src/Windows/Layout.h index 0e85bc648b..48eb9de2e5 100644 --- a/src/wxxt/src/Windows/Layout.h +++ b/src/wxxt/src/Windows/Layout.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/ListBox.cc b/src/wxxt/src/Windows/ListBox.cc index e12d8490d8..16dec7f9b3 100644 --- a/src/wxxt/src/Windows/ListBox.cc +++ b/src/wxxt/src/Windows/ListBox.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/ListBox.h b/src/wxxt/src/Windows/ListBox.h index e4fe82a68e..40cc009870 100644 --- a/src/wxxt/src/Windows/ListBox.h +++ b/src/wxxt/src/Windows/ListBox.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Menu.cc b/src/wxxt/src/Windows/Menu.cc index 0fe2ba3ecf..7617ca75e9 100644 --- a/src/wxxt/src/Windows/Menu.cc +++ b/src/wxxt/src/Windows/Menu.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Menu.h b/src/wxxt/src/Windows/Menu.h index d11e3830b8..2d4524657c 100644 --- a/src/wxxt/src/Windows/Menu.h +++ b/src/wxxt/src/Windows/Menu.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/MenuBar.cc b/src/wxxt/src/Windows/MenuBar.cc index 598a5ed6c5..baf6bc050b 100644 --- a/src/wxxt/src/Windows/MenuBar.cc +++ b/src/wxxt/src/Windows/MenuBar.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/MenuBar.h b/src/wxxt/src/Windows/MenuBar.h index eba329c7b8..7b1eb7c1da 100644 --- a/src/wxxt/src/Windows/MenuBar.h +++ b/src/wxxt/src/Windows/MenuBar.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Message.cc b/src/wxxt/src/Windows/Message.cc index 3936e7ab16..4f0463ff48 100644 --- a/src/wxxt/src/Windows/Message.cc +++ b/src/wxxt/src/Windows/Message.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Message.h b/src/wxxt/src/Windows/Message.h index 2a84dee5c1..9055f06533 100644 --- a/src/wxxt/src/Windows/Message.h +++ b/src/wxxt/src/Windows/Message.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Panel.cc b/src/wxxt/src/Windows/Panel.cc index 159dccca06..7009efc62f 100644 --- a/src/wxxt/src/Windows/Panel.cc +++ b/src/wxxt/src/Windows/Panel.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Panel.h b/src/wxxt/src/Windows/Panel.h index 889e4f264c..4a1e2c3696 100644 --- a/src/wxxt/src/Windows/Panel.h +++ b/src/wxxt/src/Windows/Panel.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/RadioBox.cc b/src/wxxt/src/Windows/RadioBox.cc index 9dbe733395..6525ef942c 100644 --- a/src/wxxt/src/Windows/RadioBox.cc +++ b/src/wxxt/src/Windows/RadioBox.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/RadioBox.h b/src/wxxt/src/Windows/RadioBox.h index 80b1625fcf..b0875f7e67 100644 --- a/src/wxxt/src/Windows/RadioBox.h +++ b/src/wxxt/src/Windows/RadioBox.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Slider.cc b/src/wxxt/src/Windows/Slider.cc index 9c4397f607..60696e7b6e 100644 --- a/src/wxxt/src/Windows/Slider.cc +++ b/src/wxxt/src/Windows/Slider.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Slider.h b/src/wxxt/src/Windows/Slider.h index 59faaf46d5..3a2277ca28 100644 --- a/src/wxxt/src/Windows/Slider.h +++ b/src/wxxt/src/Windows/Slider.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Window.cc b/src/wxxt/src/Windows/Window.cc index e3f2120f86..259a9ce0dd 100644 --- a/src/wxxt/src/Windows/Window.cc +++ b/src/wxxt/src/Windows/Window.cc @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/Windows/Window.h b/src/wxxt/src/Windows/Window.h index dd505933c2..3b5a312135 100644 --- a/src/wxxt/src/Windows/Window.h +++ b/src/wxxt/src/Windows/Window.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/XWidgets/xwMenu.c b/src/wxxt/src/XWidgets/xwMenu.c index 0f6a108b11..f931b6b041 100644 --- a/src/wxxt/src/XWidgets/xwMenu.c +++ b/src/wxxt/src/XWidgets/xwMenu.c @@ -1,5 +1,5 @@ /*********************************************************** -Copyright 2004-2008 PLT Scheme Inc. +Copyright 2004-2009 PLT Scheme Inc. Copyright 1995 by Markus Holzem All Rights Reserved diff --git a/src/wxxt/src/XWidgets/xwMenu.h b/src/wxxt/src/XWidgets/xwMenu.h index 29a8e986d7..04a0c6e2c3 100644 --- a/src/wxxt/src/XWidgets/xwMenu.h +++ b/src/wxxt/src/XWidgets/xwMenu.h @@ -1,5 +1,5 @@ /*********************************************************** -Copyright 2004-2008 PLT Scheme Inc. +Copyright 2004-2009 PLT Scheme Inc. Copyright 1995 by Markus Holzem All Rights Reserved diff --git a/src/wxxt/src/XWidgets/xwMenuP.h b/src/wxxt/src/XWidgets/xwMenuP.h index 84ad773b2f..5f45e7eb54 100644 --- a/src/wxxt/src/XWidgets/xwMenuP.h +++ b/src/wxxt/src/XWidgets/xwMenuP.h @@ -1,5 +1,5 @@ /*********************************************************** -Copyright 2004-2008 PLT Scheme Inc. +Copyright 2004-2009 PLT Scheme Inc. Copyright 1995 by Markus Holzem All Rights Reserved diff --git a/src/wxxt/src/XWidgets/xwMultiList.c b/src/wxxt/src/XWidgets/xwMultiList.c index 1e887a16e3..3646028c79 100644 --- a/src/wxxt/src/XWidgets/xwMultiList.c +++ b/src/wxxt/src/XWidgets/xwMultiList.c @@ -36,7 +36,7 @@ */ /* - * Copyright 2004-2008 PLT Scheme Inc. + * Copyright 2004-2009 PLT Scheme Inc. * Copyright 1989 Massachusetts Institute of Technology * * Permission to use, copy, modify, distribute, and sell this software and its diff --git a/src/wxxt/src/XWidgets/xwMultiList.h b/src/wxxt/src/XWidgets/xwMultiList.h index 8c974062e6..317102dea1 100644 --- a/src/wxxt/src/XWidgets/xwMultiList.h +++ b/src/wxxt/src/XWidgets/xwMultiList.h @@ -28,7 +28,7 @@ */ /* - * Copyright 2004-2008 PLT Scheme Inc. + * Copyright 2004-2009 PLT Scheme Inc. * Copyright 1989 Massachusetts Institute of Technology * * Permission to use, copy, modify, distribute, and sell this software and its diff --git a/src/wxxt/src/XWidgets/xwMultiListP.h b/src/wxxt/src/XWidgets/xwMultiListP.h index f6990bab08..afeb178627 100644 --- a/src/wxxt/src/XWidgets/xwMultiListP.h +++ b/src/wxxt/src/XWidgets/xwMultiListP.h @@ -28,7 +28,7 @@ */ /* - * Copyright 2004-2008 PLT Scheme Inc. + * Copyright 2004-2009 PLT Scheme Inc. * Copyright 1989 Massachusetts Institute of Technology * * Permission to use, copy, modify, distribute, and sell this software and its diff --git a/src/wxxt/src/XWidgets/xwScrollText.c b/src/wxxt/src/XWidgets/xwScrollText.c index a83811ad25..5af7954d38 100644 --- a/src/wxxt/src/XWidgets/xwScrollText.c +++ b/src/wxxt/src/XWidgets/xwScrollText.c @@ -1,5 +1,5 @@ /* - * Copyright 2004-2008 PLT Scheme Inc. + * Copyright 2004-2009 PLT Scheme Inc. * Copyright 1992, 1994 The University of Newcastle upon Tyne * * Permission to use, copy, modify and distribute this software and its diff --git a/src/wxxt/src/XWidgets/xwScrollText.h b/src/wxxt/src/XWidgets/xwScrollText.h index 4ac38ce2e8..8aff6ec579 100644 --- a/src/wxxt/src/XWidgets/xwScrollText.h +++ b/src/wxxt/src/XWidgets/xwScrollText.h @@ -1,5 +1,5 @@ /* - * Copyright 2004-2008 PLT Scheme Inc. + * Copyright 2004-2009 PLT Scheme Inc. * Copyright 1992 The University of Newcastle upon Tyne * * Permission to use, copy, modify and distribute this software and its diff --git a/src/wxxt/src/XWidgets/xwScrollTextP.h b/src/wxxt/src/XWidgets/xwScrollTextP.h index 279c44d25a..51b8ba5bda 100644 --- a/src/wxxt/src/XWidgets/xwScrollTextP.h +++ b/src/wxxt/src/XWidgets/xwScrollTextP.h @@ -1,5 +1,5 @@ /* - * Copyright 2004-2008 PLT Scheme Inc. + * Copyright 2004-2009 PLT Scheme Inc. * Copyright 1992 The University of Newcastle upon Tyne * * Permission to use, copy, modify and distribute this software and its diff --git a/src/wxxt/src/XWidgets/xwTools3d.c b/src/wxxt/src/XWidgets/xwTools3d.c index e0e920d51f..eec25261d4 100644 --- a/src/wxxt/src/XWidgets/xwTools3d.c +++ b/src/wxxt/src/XWidgets/xwTools3d.c @@ -1,5 +1,5 @@ /*********************************************************** -Copyright 2004-2008 PLT Scheme Inc. +Copyright 2004-2009 PLT Scheme Inc. Copyright 1987, 1988 by Digital Equipment Corporation, Maynard, Massachusetts, and the Massachusetts Institute of Technology, Cambridge, Massachusetts. Copyright 1995 by Markus Holzem diff --git a/src/wxxt/src/XWidgets/xwTools3d.h b/src/wxxt/src/XWidgets/xwTools3d.h index 49891e261d..e5aaa84edf 100644 --- a/src/wxxt/src/XWidgets/xwTools3d.h +++ b/src/wxxt/src/XWidgets/xwTools3d.h @@ -2,7 +2,7 @@ */ /*********************************************************** -Copyright 2004-2008 PLT Scheme Inc. +Copyright 2004-2009 PLT Scheme Inc. Copyright 1987, 1988 by Digital Equipment Corporation, Maynard, Massachusetts, and the Massachusetts Institute of Technology, Cambridge, Massachusetts. Copyright 1995 by Markus Holzem diff --git a/src/wxxt/src/wx.h b/src/wxxt/src/wx.h index 34edfa2f7c..470fa844be 100644 --- a/src/wxxt/src/wx.h +++ b/src/wxxt/src/wx.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/wxDefines.h b/src/wxxt/src/wxDefines.h index 6e27903707..b0c4fcb580 100644 --- a/src/wxxt/src/wxDefines.h +++ b/src/wxxt/src/wxDefines.h @@ -4,7 +4,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/src/wxSetup.h b/src/wxxt/src/wxSetup.h index f0dced466c..8a24ebe071 100644 --- a/src/wxxt/src/wxSetup.h +++ b/src/wxxt/src/wxSetup.h @@ -5,7 +5,7 @@ * * Authors: Markus Holzem and Julian Smart * - * Copyright: (C) 2004-2008 PLT Scheme Inc. + * Copyright: (C) 2004-2009 PLT Scheme Inc. * Copyright: (C) 1995, AIAI, University of Edinburgh (Julian) * Copyright: (C) 1995, GNU (Markus) * diff --git a/src/wxxt/utils/image/src/wx_image.cc b/src/wxxt/utils/image/src/wx_image.cc index 09f0c3e996..7e7075b5a1 100644 --- a/src/wxxt/utils/image/src/wx_image.cc +++ b/src/wxxt/utils/image/src/wx_image.cc @@ -3,7 +3,7 @@ * Purpose: * * wxWindows 1.50 - * Copyright (c) 2004-2008 PLT Scheme Inc. + * Copyright (c) 2004-2009 PLT Scheme Inc. * Copyright (c) 1993 Artificial Intelligence Applications Institute, * The University of Edinburgh * diff --git a/src/wxxt/utils/image/src/wx_image.h b/src/wxxt/utils/image/src/wx_image.h index abc19177a1..5796adc6a9 100644 --- a/src/wxxt/utils/image/src/wx_image.h +++ b/src/wxxt/utils/image/src/wx_image.h @@ -3,7 +3,7 @@ * Purpose: * * wxWindows 1.50 - * Copyright (c) 2004-2008 PLT Scheme Inc. + * Copyright (c) 2004-2009 PLT Scheme Inc. * Copyright (c) 1993 Artificial Intelligence Applications Institute, * The University of Edinburgh * diff --git a/src/wxxt/utils/image/src/wx_imgx.h b/src/wxxt/utils/image/src/wx_imgx.h index 12a9eeb196..2bfa6d4517 100644 --- a/src/wxxt/utils/image/src/wx_imgx.h +++ b/src/wxxt/utils/image/src/wx_imgx.h @@ -3,7 +3,7 @@ * Purpose: * * wxWindows 1.50 - * Copyright (c) 2004-2008 PLT Scheme Inc. + * Copyright (c) 2004-2009 PLT Scheme Inc. * Copyright (c) 1993 Artificial Intelligence Applications Institute, * The University of Edinburgh * From 9b84def3c1314f9639e0df282e7959a3a49ea2a5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Jan 2009 18:08:37 +0000 Subject: [PATCH 18/49] PR 10002 svn: r13002 --- collects/redex/private/reduction-semantics.ss | 42 ++++++++++++------- 1 file changed, 26 insertions(+), 16 deletions(-) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 653464e38c..18aa7ef857 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -1045,25 +1045,35 @@ (define (check-clauses stx syn-error-name rest) (syntax-case rest () - [([(lhs ...) roc ...] ...) + [([(lhs ...) roc1 roc2 ...] ...) rest] + [([(lhs ...) rhs ...] ...) + (begin + (for-each + (λ (clause) + (syntax-case clause () + [(a b) (void)] + [x (raise-syntax-error syn-error-name "expected a pattern and a right-hand side" stx clause)])) + (syntax->list #'([(lhs ...) rhs ...] ...))) + (raise-syntax-error syn-error-name "error checking failed.3" stx))] [([x roc ...] ...) - (for-each - (λ (x) - (syntax-case x () - [(lhs ...) (void)] - [x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)])) - (syntax->list #'(x ...))) - (raise-syntax-error syn-error-name "error checking failed.1" stx)] + (begin + (for-each + (λ (x) + (syntax-case x () + [(lhs ...) (void)] + [x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)])) + (syntax->list #'(x ...))) + (raise-syntax-error syn-error-name "error checking failed.1" stx))] [(x ...) - (for-each - (λ (x) - (syntax-case x () - [(stuff ...) (void)] - [x (raise-syntax-error syn-error-name "expected a metafunction clause" stx #'x)])) - (syntax->list #'(x ...))) - (raise-syntax-error syn-error-name "error checking failed.2" stx)])) - + (begin + (for-each + (λ (x) + (syntax-case x () + [(stuff ...) (void)] + [x (raise-syntax-error syn-error-name "expected a metafunction clause" stx #'x)])) + (syntax->list #'(x ...))) + (raise-syntax-error syn-error-name "error checking failed.2" stx))])) (define (extract-side-conditions name stx stuffs) (let loop ([stuffs (syntax->list stuffs)] From 206553c8166f45b45e8c8b1373d28243e1cf750b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Jan 2009 18:10:32 +0000 Subject: [PATCH 19/49] added clarification to the docs about caching svn: r13003 --- collects/redex/redex.scrbl | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 360da14277..4dc2dc7d97 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -79,8 +79,12 @@ All of the exports in this section are provided both by all non-GUI portions of Redex) and also exported by @schememodname[redex] (which includes all of Redex). -This section covers Redex's @deftech{pattern} language, used -in various ways: +This section covers Redex's @deftech{pattern} language, used in many +of Redex's forms. + +Note that pattern matching is caching (including caching the results +of side-conditions). This means that once a pattern has matched a +given term, Redex assumes that it will always match that term. @(schemegrammar* #:literals (any number string variable variable-except variable-prefix variable-not-otherwise-mentioned hole name in-hole side-condition cross) [pattern any From 821a82195e6947a96a97df0f7928e0ba0f799247 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Jan 2009 23:15:50 +0000 Subject: [PATCH 20/49] change 'help' to open the main doc page instead of the docs for 'help' itself svn: r13004 --- collects/help/help-utils.ss | 10 +++++-- collects/help/search.ss | 4 ++- collects/scheme/help.ss | 32 +++++++++++++---------- collects/scribblings/reference/help.scrbl | 3 ++- 4 files changed, 31 insertions(+), 18 deletions(-) diff --git a/collects/help/help-utils.ss b/collects/help/help-utils.ss index 8e69e454cb..0388c69432 100644 --- a/collects/help/help-utils.ss +++ b/collects/help/help-utils.ss @@ -14,7 +14,7 @@ scheme/list "search.ss") -(provide search-for find-help find-help/lib) +(provide search-for find-help find-help/lib go-to-main-page) (define (search-for strs) (perform-search (apply string-append (add-between strs " ")))) @@ -64,9 +64,15 @@ (printf " ~a\n" (car libs))) (loop (cdr libs)))))))) +(define (report-sending-browser file) + (printf "Sending to web browser...\n file: ~a\n" file)) + +(define (go-to-main-page) + (send-main-page #:notify report-sending-browser)) + (define (go-to-tag xref t) (let-values ([(file anchor) (xref-tag->path+anchor xref t)]) - (printf "Sending to web browser...\n file: ~a\n" file) + (report-sending-browser file) (when anchor (printf " anchor: ~a\n" anchor)) (unless (send-url/file file #:fragment (and anchor (uri-encode anchor))) (error 'help "browser launch failed")))) diff --git a/collects/help/search.ss b/collects/help/search.ss index c7e15cbf61..b83c3c3db2 100644 --- a/collects/help/search.ss +++ b/collects/help/search.ss @@ -9,9 +9,11 @@ ;; using javascript. (define (send-main-page #:sub [sub "index.html"] - #:fragment [fragment #f] #:query [query #f]) + #:fragment [fragment #f] #:query [query #f] + #:notify [notify void]) (let* ([path (build-path (find-user-doc-dir) sub)] [path (if (file-exists? path) path (build-path (find-doc-dir) sub))]) + (notify path) (send-url/file path #:fragment fragment #:query query))) ;; This is an example of changing this code to use the online manuals. diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index da6966a0c4..dba69b06e3 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -33,31 +33,34 @@ (raise-syntax-error #f (string-append "expects a single identifer, a #:from clause, or a" - " #:search clause; try just `help' for more information") + " #:search clause; try `(help help)' for more information") stx)]))) (define (open-help-start) - (find-help #'help)) + (go-to-main-page)) ;; Autoload utilities from help/help-utils; if it does not exists, ;; suggest using docs.plt-scheme.org. (define-namespace-anchor anchor) (define get-binding - (let ([ns #f] [utils #f]) + (let ([ns #f]) (lambda (sym) (unless ns - (set! ns (namespace-anchor->empty-namespace anchor)) - (set! utils (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join 'help/help-utils #f))))) - (parameterize ([current-namespace ns]) - (if (file-exists? utils) - (dynamic-require utils sym) - (lambda _ - (error 'help "documentation system unavailable; ~a\n~a" - "try http://docs.plt-scheme.org/" - (format " (missing file: ~a)" utils)))))))) + (set! ns (namespace-anchor->empty-namespace anchor))) + (with-handlers ([exn:fail? + (lambda (exn) + ((error-display-handler) + (if (exn? exn) + (exn-message exn) + (format "~s" exn)) + exn) + (raise-user-error + 'help + (string-append + "documentation system unavailable; " + "try http://docs.plt-scheme.org/")))]) + (dynamic-require 'help/help-utils sym))))) (define-syntax-rule (define-help-autoload id) (define id @@ -67,3 +70,4 @@ (define-help-autoload find-help) (define-help-autoload find-help/lib) (define-help-autoload search-for) +(define-help-autoload go-to-main-page) diff --git a/collects/scribblings/reference/help.scrbl b/collects/scribblings/reference/help.scrbl index 1d2b11a3fc..b98f6f070f 100644 --- a/collects/scribblings/reference/help.scrbl +++ b/collects/scribblings/reference/help.scrbl @@ -32,7 +32,8 @@ browser (using the user's selected browser) to display the results. @margin-note{See @schememodname[net/sendurl] for information on how the user's browser is launched to display help information.} -A simple @scheme[help] or @scheme[(help)] form opens this page. +A simple @scheme[help] or @scheme[(help)] form opens the main +documentation page. A @scheme[(help id)] form looks for documentation specific to the current binding of @scheme[id]. For example, From d797e18abce23e5c98a87692ee8951dd425cb910 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 5 Jan 2009 01:43:36 +0000 Subject: [PATCH 21/49] https port fix and clarifications svn: r13005 --- collects/handin-server/scribblings/quick-start.scrbl | 2 +- collects/handin-server/scribblings/server-setup.scrbl | 10 ++++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/collects/handin-server/scribblings/quick-start.scrbl b/collects/handin-server/scribblings/quick-start.scrbl index dc522b882e..a4361fee96 100644 --- a/collects/handin-server/scribblings/quick-start.scrbl +++ b/collects/handin-server/scribblings/quick-start.scrbl @@ -27,7 +27,7 @@ @item{Create a file @filepath{config.ss} with the following content: @schemeblock[((active-dirs ("test")) - (https-port-number 9780))]} + (https-port-number 7980))]} @item{In your new directory, run @commandline{mred-text -l handin-server}} diff --git a/collects/handin-server/scribblings/server-setup.scrbl b/collects/handin-server/scribblings/server-setup.scrbl index 90429b0d91..6f68ba9964 100644 --- a/collects/handin-server/scribblings/server-setup.scrbl +++ b/collects/handin-server/scribblings/server-setup.scrbl @@ -469,8 +469,11 @@ limited to one whenever possible. When multiple assignments are active, design a checker to help ensure that the student has selected the correct assignment in the handin dialog. -A student can download his/her own submissions through a web server -that runs concurrently with the handin server. The starting URL is +A student can download his/her own submissions through the handin +dialog. This can also be done through a web server that runs +concurrently with the handin server if you use the +@scheme[https-port-number] option in the configuration file. The +starting URL is @commandline{https://SERVER:PORT/} @@ -478,5 +481,4 @@ to obtain a list of all assignments, or @commandline{https://SERVER:PORT/?handin=ASSIGNMENT} -to start with a specific assignment (named ASSIGNMENT). The default -PORT is 7980. +to start with a specific assignment (named ASSIGNMENT). From c7870e6ec5dd7301337f4025d805fa78ff21fa0c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 5 Jan 2009 08:50:16 +0000 Subject: [PATCH 22/49] Welcome to a new PLT day. svn: r13006 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 6388e25ae4..bfa215a4ee 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "4jan2009") +#lang scheme/base (provide stamp) (define stamp "5jan2009") From dc4aac224d2ee1f616c7b046efd3cbac25e14b3f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Jan 2009 10:13:18 +0000 Subject: [PATCH 23/49] 2htdp docs: no 'blockquote style svn: r13007 --- collects/teachpack/2htdp/scribblings/universe.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index e6485da455..b1c1c6b919 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -10,7 +10,7 @@ @(define (table* . stuff) ;; (list paragraph paragraph) *-> Table (define (flow* x) (make-flow (list x))) - (make-blockquote 'blockquote + (make-blockquote #f (list (make-table (make-with-attributes 'boxed '((cellspacing . "6"))) From c2857c1b7ce7cc1dde3cbfeb0e0175b422a2138c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Jan 2009 10:20:17 +0000 Subject: [PATCH 24/49] use define-unsafer for ffi/objc; fix more teachpack doc latex-output problems svn: r13008 --- collects/ffi/objc.scrbl | 21 +++++++++++++++++++-- collects/ffi/objc.ss | 21 +++++++++++++-------- collects/ffi/private/objc-doc-unsafe.ss | 10 ++++++++++ collects/scribble/latex-render.ss | 8 +++++++- collects/teachpack/balls.png | Bin 0 -> 1505 bytes src/mac/cw/MrEd.r | 2 +- 6 files changed, 50 insertions(+), 12 deletions(-) create mode 100644 collects/ffi/private/objc-doc-unsafe.ss create mode 100644 collects/teachpack/balls.png diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl index 00f4985c85..e4564f6161 100644 --- a/collects/ffi/objc.scrbl +++ b/collects/ffi/objc.scrbl @@ -3,7 +3,7 @@ scribble/eval (for-label scheme/base scheme/foreign - ffi/objc)) + "private/objc-doc-unsafe.ss")) @(define objc-eval (make-base-eval)) @(interaction-eval #:eval objc-eval (define-struct cpointer:id ())) @@ -13,7 +13,9 @@ @title{@bold{Objective-C} FFI} -@defmodule[ffi/objc]{The @schememodname[ffi/objc] library builds on +@declare-exporting[ffi/private/objc-doc-unsafe #:use-sources (ffi/objc)] + +@defmodule*/no-declare[(ffi/objc)]{The @schememodname[ffi/objc] library builds on @schememodname[scheme/foreign] to support interaction with @link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.} @@ -26,8 +28,23 @@ relatively low-level compared to normal Scheme libraries, because argument and result types must be declared in terms of FFI C types (@seeCtype). +@bold{Important:} Most of the bindings documented here are available +only after an @scheme[(objc-unsafe!)] declaration in the importing +module. + @table-of-contents[] +@; ---------------------------------------------------------------------- + +@section{Using Unsafe Bindings} + +@defform[(objc-unsafe!)]{ + +Analogous to @scheme[(unsafe!)], makes unsafe bindings of +@schememodname[ffi/objc] available in the importing module.} + +@; ---------------------------------------------------------------------- + @section{FFI Types and Constants} @defthing[_id ctype?]{ diff --git a/collects/ffi/objc.ss b/collects/ffi/objc.ss index 8c9be4ccb9..0b89fb3eb9 100644 --- a/collects/ffi/objc.ss +++ b/collects/ffi/objc.ss @@ -15,7 +15,7 @@ (define-syntax-rule (define-objc id type) (begin - (provide id) + (provide* (unsafe id)) (define-objc/private id id type))) ;; ---------------------------------------- @@ -86,16 +86,16 @@ (define msgSends (make-hash)) (define (objc_msgSend/typed types) (lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id)) -(provide objc_msgSend/typed) +(provide* (unsafe objc_msgSend/typed)) (define msgSendSupers (make-hash)) (define (objc_msgSendSuper/typed types) (lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer)) -(provide objc_msgSendSuper/typed) +(provide* (unsafe objc_msgSendSuper/typed)) ;; ---------------------------------------- -(provide import-class) +(provide* (unsafe import-class)) (define-syntax (import-class stx) (syntax-case stx () [(_ id) @@ -107,7 +107,7 @@ ;; ---------------------------------------- ;; iget-value and set-ivar! work only with fields that contain Scheme values -(provide get-ivar set-ivar!) +(provide* (unsafe get-ivar) (unsafe set-ivar!)) (define-for-syntax (check-ivar ivar stx) (unless (identifier? ivar) @@ -161,7 +161,7 @@ (hash-set! method-sels sym id) id))) -(provide selector) +(provide* (unsafe selector)) (define-syntax (selector stx) (syntax-case stx () [(_ id) @@ -256,7 +256,7 @@ arg))) (loop (cdr rest)))))))) -(provide tell tellv) +(provide* (unsafe tell) (unsafe tellv)) (define-for-syntax (build-send stx result-type send/typed send-args l-stx) (let ([l (syntax->list l-stx)]) (with-syntax ([((tag type arg) ...) (parse-arg-list l stx #f)] @@ -329,7 +329,7 @@ ;; ---------------------------------------- -(provide define-objc-class self super-tell) +(provide* (unsafe define-objc-class) self super-tell) (define-syntax (define-objc-class stx) (syntax-case stx () @@ -549,3 +549,8 @@ #'objc_msgSendSuper/typed #'((make-objc_super self super-class)) #'(method/arg ...))])) + +;; -------------------------------------------------- + +(define-unsafer objc-unsafe!) + diff --git a/collects/ffi/private/objc-doc-unsafe.ss b/collects/ffi/private/objc-doc-unsafe.ss new file mode 100644 index 0000000000..20ecc1eb89 --- /dev/null +++ b/collects/ffi/private/objc-doc-unsafe.ss @@ -0,0 +1,10 @@ +#lang scheme/base + +(require ffi/objc) + +(error 'objc-unsafe! "only `for-label' use in the documentation") + +(objc-unsafe!) + +(provide (protect-out (all-defined-out)) + (all-from-out ffi/objc)) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 5c88ec23e5..23b6c0e67e 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -4,6 +4,7 @@ mzlib/class scheme/runtime-path scheme/port + scheme/path scheme/string setup/main-collects) (provide render-mixin) @@ -18,6 +19,11 @@ (define-runtime-path scribble-tex "scribble.tex") +(define (gif-to-png p) + (if (equal? (filename-extension p) #"gif") + (path-replace-suffix p #".png") + p)) + (define (render-mixin %) (class % (init-field [style-file #f] @@ -194,7 +200,7 @@ (void) (let ([fn (install-file (main-collects-relative->path - (image-file-path style)))]) + (gif-to-png (image-file-path style))))]) (printf "\\includegraphics[scale=~a]{~a}" (image-file-scale style) fn)))] [else (super render-element e part ri)]))) diff --git a/collects/teachpack/balls.png b/collects/teachpack/balls.png new file mode 100644 index 0000000000000000000000000000000000000000..03ea3eb596e145ff37dbd99dba59d6753b2d30ba GIT binary patch literal 1505 zcmV<71s?i|P)?PNfdsLpiFU=KZR1(**b~;@ z8#(j$=FQCKZy#^hJ5(BtMq5fCQ&UqV*hRc8?C$Qyn>^sm69H|}6cLDy00|xaE8qe` zB0xgtK(iv19NJWkfdC1e1NF9);&vm)j(gJJJL} zj=D)xnn~U4Si9AsYj)~VPs*rU8}xhGFk8%fBQTbP?hVIj4+y=l>8YkaHDzU9<`dGR z9lEHStjemq(uDC#np`ov=IPOYs0npzgZ}qyxb|4?M4&Q`kL}`mvw+y)4x|QKU z7c_y4@Zuo;O--hs6w*I7kBxQv;Gsd@ZB6b)0bN(jhT9gp%*S@25&ePefxO3>5RM=> zGTRnFKugxvEnk$yuK#v*-3@%Lpxy5VnBSCV6bw80M!4 zjAabXFTWE3#?YOZu!RUjM<7?oF+JV?1)vu%ewNwU+v1}eefL~IFa)Nir@d_X>UkOK zqLho!UB-7bZEjwd$B+M#M&tDDEfTu}qEa^OHX4QZ6@u&o6Z+%F$um#9w|6PojFES4 z?#?%LYcITG8aNjSfOwbo_T={LtQZL`#{w_3T5@Z7IqAE;xp}5zi?^|V+`lhBHJeGZ zjknx%^X3B+x?cZPHa6bL*4DnjD?`jH_sa7wj{4^pfy-~+$o|%rbo0!=J$fXqYuA!K zE+`O#5&&QNpIO?+&aF7sjtkkBc9OG|pb?@-V8 z>CK^ggSfh?X9QpA8Nq!$Bd9vAfZ%9{{`|b2GfWAO9CZ^P8>Y*=7y^9Cq4>euZf|c3 zh=<%IBl=u1vZLL~=!X|xSkQBZdQsGBdd~2vo-<4zS^3z=+H>a|MR{0HIYzN|cMf{! z6ph72J>RD!MCbuxy8`0c$8C4ZAn)<9o-=%{=L|JBGMkQ#cP|3#V;&9x657FXW=7BV zsfS))ch2`|n}rgNYS$t>JG`{(;h_k-zBalVW}`O(ByjG&;Q~l)VqV+&t-V_g zFAwjG+?6~w+;J@DM}RT3Vir4o#n%>l4P}X;`NK*|CJ-v7#GXIq-b2n!LMxglCnq5> zrLBkvFouo@KBo?k00|u)Q(BCO00|utd`=x60TMbqrnDFl0TMbQ_?$XC0wi>JOldJ9 z0wi=q@HusO1W4%cn9^cI1W4$J;B)Hm2$0a>F{Q zg3qbLBQUhL?JA!>Nljmrzw+{Bvg&{D-jzc=WZJ%XG5juQkqD#+42{q={l9~+K7W1& z^wnq2lJegV9-OtYKm Date: Mon, 5 Jan 2009 10:24:02 +0000 Subject: [PATCH 25/49] doc .gif->.png for Scribble Latex output svn: r13009 --- collects/scribblings/scribble/manual.scrbl | 6 +++++- collects/scribblings/scribble/struct.scrbl | 5 ++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 3676d8549e..3518eb1269 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -943,7 +943,11 @@ combination of @scheme[envvar] and @scheme[as-index].} The path is relative to the current directory, which is set by @exec{setup-plt} and @exec{scribble} to the directory of the main - document file.} + document file. + + When generating Latex output, if the filename has a @filepath{.gif} + suffix, then the suffix is changed to @filepath{.png} (so a PNG file + must exist in addition to the GIF file).} @defproc[(image/plain [filename-relative-to-source string?] [pre-element any/c] ...) diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index 7ad68e05a2..13afd6e48d 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -666,7 +666,10 @@ layer is a style for the hyperlink.} Used as a style for an @scheme[element] to inline an image. The @scheme[path] field can be a result of -@scheme[path->main-collects-relative].} +@scheme[path->main-collects-relative]. + +For Latex output, a @filepath{.gif} suffix on @scheme[path] is +replaced with a @filepath{.png} suffix.} @defproc[(block? [v any/c]) boolean?]{ From 332461c30e5d9188d4e292bc8231b0bdd1b7b2c1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Jan 2009 12:06:33 +0000 Subject: [PATCH 26/49] fix problem with gif->png suffix change; fix ToC when a subsection has a tag prefix svn: r13010 --- collects/scribble/base-render.ss | 14 ++++++++++---- collects/scribble/latex-render.ss | 5 +++-- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index 78d23fabbd..153ee41e5a 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -443,7 +443,8 @@ (part-collected-info part ri)))) #t quiet - depth))) + depth + null))) (define/public (table-of-contents part ri) (do-table-of-contents part ri -1 not +inf.0)) @@ -456,14 +457,17 @@ (define/public (quiet-table-of-contents part ri) (do-table-of-contents part ri 1 (lambda (x) #t) +inf.0)) - (define/private (generate-toc part ri base-len skip? quiet depth) + (define/private (generate-toc part ri base-len skip? quiet depth prefixes) (let* ([number (collected-info-number (part-collected-info part ri))] + [prefixes (if (part-tag-prefix part) + (cons (part-tag-prefix part) prefixes) + prefixes)] [subs (if (and (quiet (and (part-style? part 'quiet) (not (= base-len (sub1 (length number)))))) (positive? depth)) (apply append (map (lambda (p) - (generate-toc p ri base-len #f quiet (sub1 depth))) + (generate-toc p ri base-len #f quiet (sub1 depth) prefixes)) (part-parts part))) null)]) (if skip? @@ -485,7 +489,9 @@ number (list (make-element 'hspace '(" ")))) (or (part-title-content part) '("???"))) - (car (part-tags part)))))))) + (for/fold ([t (car (part-tags part))]) + ([prefix (in-list prefixes)]) + (convert-key prefix t)))))))) subs)]) (if (and (= 1 (length number)) (or (not (car number)) ((car number) . > . 1))) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 23b6c0e67e..ea2bf3a5ba 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -199,8 +199,9 @@ (if (disable-images) (void) (let ([fn (install-file - (main-collects-relative->path - (gif-to-png (image-file-path style))))]) + (gif-to-png + (main-collects-relative->path + (image-file-path style))))]) (printf "\\includegraphics[scale=~a]{~a}" (image-file-scale style) fn)))] [else (super render-element e part ri)]))) From 08201a309de2e5ee9fde69f1c13c030741514d61 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Jan 2009 12:21:09 +0000 Subject: [PATCH 27/49] teachpack 2htdp docs: fix multiple definitions svn: r13011 --- .../teachpack/2htdp/scribblings/2htdp.scrbl | 2 +- .../2htdp/scribblings/universe.scrbl | 146 +++++++++--------- 2 files changed, 78 insertions(+), 70 deletions(-) diff --git a/collects/teachpack/2htdp/scribblings/2htdp.scrbl b/collects/teachpack/2htdp/scribblings/2htdp.scrbl index 9f1a950ef6..6b46bc665b 100644 --- a/collects/teachpack/2htdp/scribblings/2htdp.scrbl +++ b/collects/teachpack/2htdp/scribblings/2htdp.scrbl @@ -3,7 +3,7 @@ @(require scribble/manual (for-label scheme)) -@title[#:style '(toc) #:tag "2htdp"]{HtDP/2e Teachpacks} +@title[#:style '(toc) #:tag "2htdp" #:tag-prefix "2htdp"]{HtDP/2e Teachpacks} @local-table-of-contents[] diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index b1c1c6b919..a0f6cd7983 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -25,11 +25,16 @@ @author{Matthias Felleisen} +@;{FIXME: the following paragraph uses `defterm' instead of `deftech', + because the words "world" and "universe" are used as datatypes, and + datatypes are currently linked as technical terms --- which is a hack. + Fix the paragraph when we have a better way to link datatype names.} + This @tt{universe.ss} teachpack implements and provides the functionality for creating interactive, graphical programs that consist of plain - mathematical functions. We refer to such programs as @deftech{world} + mathematical functions. We refer to such programs as @defterm{world} programs. In addition, world programs can also become a part of a - @deftech{universe}, a collection of worlds that can exchange messages. + @defterm{universe}, a collection of worlds that can exchange messages. The purpose of this documentation is to give experienced Schemers and HtDP teachers a concise overview for using the library. The first part of the @@ -55,8 +60,8 @@ The purpose of this documentation is to give experienced Schemers and HtDP The teachpack assumes working knowledge of the basic image manipulation primitives and supports several functions that require a special kind of - image, called a @deftech{scene}, , which are images whose pinholes are at - position @scheme[(0,0)]. For example, the teachpack displays only + image, called a @deftech{scene}, which is an image whose pinholes are at + position @math{(0, 0)}. For example, the teachpack displays only @tech{scene}s in its canvas. @defproc[(scene? [x any/c]) boolean?]{ @@ -70,9 +75,10 @@ The teachpack assumes working knowledge of the basic image manipulation @defproc[(place-image [img image?] [x number?] [y number?] [s scene?]) scene?]{ - creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s]; - @scheme[(x,y)] are computer graphics coordinates, i.e., they count right and - down from the upper-left corner.} + creates a scene by placing @scheme[img] at + @math{(@scheme[x], @scheme[y])} into @scheme[s]; + @math{(@scheme[x], @scheme[y])} are computer graphics coordinates, + i.e., they count right and down from the upper-left corner.} @; ----------------------------------------------------------------------------- @section[#:tag "simulations"]{Simple Simulations} @@ -85,8 +91,8 @@ The simplest kind of animated @tech{world} program is a time-based @defproc[(run-simulation [create-image (-> natural-number/c scene)]) true]{ - opens a canvas and starts a clock that tick 28 times per second - seconds. Every time the clock ticks, drscheme applies + opens a canvas and starts a clock that tick 28 times per second. + Every time the clock ticks, DrScheme applies @scheme[create-image] to the number of ticks passed since this function call. The results of these applications are displayed in the canvas. } @@ -108,7 +114,7 @@ Example: The step from simulations to interactive programs is relatively small. Roughly speaking, a simulation designates one function, - @emph{create-image}, as a handler for one kind of event: clock ticks. In + @scheme[_create-image], as a handler for one kind of event: clock ticks. In addition to clock ticks, @tech{world} programs can also deal with two other kinds of events: keyboard events and mouse events. A keyboard event is triggered when a computer user presses or releases a key on the @@ -119,8 +125,8 @@ Your program may deal with such events via the @emph{designation} of @emph{handler} functions. Specifically, the teachpack provides for the installation of three event handlers: @scheme[on-tick], @scheme[on-key], and @scheme[on-mouse]. In addition, a @tech{world} program may specify a - @emph{draw} function, which is called every time your program should - visualize the current world, and a @emph{stop?} predicate, which is used + @scheme[_dra]} function, which is called every time your program should + visualize the current world, and a @scheme[_stop?] predicate, which is used to determine when the @tech{world} program should shut down. Each handler function consumes the current state of the @tech{world} and @@ -132,20 +138,22 @@ The following picture provides an intuitive overview of the workings of a @image["nuworld.png"] - The @scheme[big-bang] form installs @emph{World_0} as the initial - world. The handlers @emph{tock}, @emph{react}, and @emph{click} transform - one world into another one; each time an event is handled, @emph{done} is + The @scheme[big-bang] form installs @scheme[World_0] as the initial + world. The handlers @scheme[tock], @scheme[react], and @scheme[click] transform + one world into another one; each time an event is handled, @scheme[done] is used to check whether the world is final, in which case the program is - shut down; and finally, @emph{draw} renders each world as a scene, which + shut down; and finally, @scheme[draw] renders each world as a scene, which is then displayed on an external canvas. -@deftech{World} : @scheme[any/c] The design of a world program demands that - you come up with a data definition of all possible states. We use - @tech{World} to refer to this collection of data, using a capital W to - distinguish it from the program. In principle, there are no constraints - on this data definition though it mustn't be an instance of the - @tech{Package} structure (see below). You can even keep it implicit, even - if this violates the Design Recipe. +@deftech{World} : @scheme[any/c] + +The design of a world program demands that you come up with a data + definition of all possible states. We use @tech{World} to refer to + this collection of data, using a capital W to distinguish it from the + program. In principle, there are no constraints on this data + definition though it mustn't be an instance of the @tech{Package} + structure (see below). You can even keep it implicit, even if this + violates the Design Recipe. @defform/subs[#:id big-bang #:literals @@ -188,9 +196,9 @@ world every time the clock ticks. The result of the call becomes the current world. The clock ticks at the rate of 28 times per second.}} @item{ -@defform[(on-tick - [tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))] - [rate-expr natural-number/c])]{ +@defform/none[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))] + [rate-expr natural-number/c])]{ tell DrScheme to call the @scheme[tick-expr] function on the current world every time the clock ticks. The result of the call becomes the current world. The clock ticks at the rate of @scheme[rate-expr].}} @@ -200,8 +208,8 @@ current world. The clock ticks at the rate of @scheme[rate-expr].}} @deftech{KeyEvent} : @scheme[(or/c char? symbol?)] -A @tech{Char} is used to signal that the user has hit an alphanumeric - key. A @tech{Symbol} denotes arrow keys or special events: +A character is used to signal that the user has hit an alphanumeric + key. A symbol denotes arrow keys or special events: @itemize[ @@ -271,7 +279,7 @@ All @tech{MouseEvent}s are represented via symbols: @defproc[(mouse-event? [x any]) boolean?]{ determines whether @scheme[x] is a @tech{KeyEvent}} -@defproc[(key=? [x mouse-event?][y mouse-event?]) boolean?]{ +@defproc[(mouse=? [x mouse-event?][y mouse-event?]) boolean?]{ compares two @tech{KeyEvent} for equality} @defform[(on-mouse @@ -297,10 +305,10 @@ All @tech{MouseEvent}s are represented via symbols: dealt with an event. Its size is determined by the size of the first generated @tech{scene}.} -@defform[(on-draw - [render-expr (-> (unsyntax @tech{World}) scene?)] - [width-expr natural-number/c] - [height-expr natural-number/c])]{ +@defform/none[(on-draw + [render-expr (-> (unsyntax @tech{World}) scene?)] + [width-expr natural-number/c] + [height-expr natural-number/c])]{ tell DrScheme to use a @scheme[width-expr] by @scheme[height-expr] canvas instead of one determine by the first generated @tech{scene}. @@ -363,12 +371,12 @@ are highly useful for creating scenes. corner.} @defproc[(scene+line [s scene?][x0 number?][y0 number?][x1 number?][y1 number?][c Color]) scene?]{ - creates a scene by placing a line of color @scheme[c] from @scheme[(x0,y0)] to - @scheme[(x1,y1)] into @scheme[scene]; - @scheme[(x,y)] are computer graphics coordinates. - In contrast to the @scheme[add-line] function, @scheme[scene+line] cuts - off those portions of the line that go beyond the boundaries of - the given @scheme[s].} + creates a scene by placing a line of color @scheme[c] from + @math{(@scheme[x0], @scheme[y0])} to @math{(@scheme[x1], + @scheme[y1])} using computer graphics coordinates. In contrast to + the @scheme[add-line] function, @scheme[scene+line] cuts off those + portions of the line that go beyond the boundaries of the given + @scheme[s].} @; ----------------------------------------------------------------------------- @section[#:tag "world-example"]{A First Sample World} @@ -395,22 +403,22 @@ Here is a diagram that translates our words into a graphical @image["door-real.png"] Like the picture of the general workings of a @tech{world} program, this - diagram displays a so-called "state machine". The three circled words are + diagram displays a so-called ``state machine.'' The three circled words are the states that our informal description of the door identified: locked, closed (and unlocked), and open. The arrows specify how the door can go from one state into another. For example, when the door is open, the automatic door closer shuts the door as time passes. This transition is - indicated by the arrow labeled "time passes." The other arrows represent + indicated by the arrow labeled ``time passes.'' The other arrows represent transitions in a similar manner: @itemize[ -@item{"push" means a person pushes the door open (and let's go);} +@item{``push'' means a person pushes the door open (and let's go);} -@item{"lock" refers to the act of inserting a key into the lock and turning +@item{``lock'' refers to the act of inserting a key into the lock and turning it to the locked position; and} -@item{"unlock" is the opposite of "lock".} +@item{``unlock'' is the opposite of ``lock.''} ] @@ -712,7 +720,7 @@ Each world-producing callback in a world program---those for handling clock predicate. @defproc[(package? [x any/c]) boolean?]{ - determine whether @scheme[x] is a @deftech{Package}.} + determine whether @scheme[x] is a @tech{Package}.} @defproc[(make-package [w any/c][m sexp?]) package?]{ create a @tech{Package} from a @tech{World} and an @tech{S-expression}.} @@ -720,23 +728,23 @@ Each world-producing callback in a world program---those for handling clock As mentioned, all event handlers may return @tech{World}s or @tech{Package}s; here are the revised specifications: -@defform[(on-tick - [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{ +@defform/none[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{ } -@defform[(on-tick - [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))] - [rate-expr natural-number/c])]{ +@defform/none[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))] + [rate-expr natural-number/c])]{ } -@defform[(on-key - [change (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{ +@defform/none[(on-key + [change (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{ } -@defform[(on-mouse - [clack - (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) - (or/c (unsyntax @tech{World}) package?))])]{ +@defform/none[(on-mouse + [clack + (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) + (or/c (unsyntax @tech{World}) package?))])]{ } If one of these event handlers produces a @tech{Package}, the content of the world @@ -778,8 +786,8 @@ following shapes: } @item{ -@defform[(register [ip-expr string?] - [name-expr (or/c symbol? string?)])]{ +@defform/none[(register [ip-expr string?] + [name-expr (or/c symbol? string?)])]{ connect this world to a universe server @emph{under a specific} @scheme[name-expr].} } @@ -848,17 +856,17 @@ The teachpack provides a mechanism for designating event handlers for @itemize[ -@item{A server may be a "pass through" channel between two worlds, in which case +@item{A server may be a ``pass through'' channel between two worlds, in which case it has no other function than to communicate whatever message it receives from one world to the other, without any interference.} -@item{A server may enforce a "back and forth" protocol, i.e., it may force two +@item{A server may enforce a ``back and forth'' protocol, i.e., it may force two (or more) worlds to engage in a civilized tit-for-tat exchange. Each world is given a chance to send a message and must then wait to get a reply before it sends anything again.} @item{A server may play the role of a special-purpose arbiter, e.g., the referee - or administrator of a game. It may check that each world "plays" by the rules, + or administrator of a game. It may check that each world ``plays'' by the rules, and it administrate the resources of the game.} ] @@ -1012,16 +1020,16 @@ optional handlers: @itemize[ @item{ -@defform[(on-tick - [tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{ +@defform/none[(on-tick + [tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{ tell DrScheme to apply @scheme[tick-expr] to the current state of the universe. The handler is expected to produce a bundle of the new state of the universe and a list of mails. } -@defform[(on-tick - [tick-expr (-> (unsyntax @tech{Universe}) bundle?)] - [rate-expr natural-number/c])]{ +@defform/none[(on-tick + [tick-expr (-> (unsyntax @tech{Universe}) bundle?)] + [rate-expr natural-number/c])]{ tell DrScheme to apply @scheme[tick-expr] as above but use the specified clock tick rate instead of the default. } @@ -1058,7 +1066,7 @@ This section uses a simple example to explain the design of a universe, @subsection{Two Ball Tossing Worlds} Say we want to represent a universe that consists of a number of worlds and - that gives each world a "turn" in a round-robin fashion. If a world is + that gives each world a ``turn'' in a round-robin fashion. If a world is given its turn, it displays a ball that ascends from the bottom of a canvas to the top. It relinquishes its turn at that point and the server gives the next world a turn. @@ -1097,7 +1105,7 @@ From the perspective of the @tech{universe}, the design of a protocol is kinds of @tech{S-expression}s. The data definitions for messages must therefore select a subset of suitable @tech{S-expression}s. As for the state of the server and the worlds, they must reflect how they currently - relate to the universe. Later, when we design their "local" behavior, we + relate to the universe. Later, when we design their ``local'' behavior, we may add more components to their state space. In summary, the first step of a protocol design is to introduce: @@ -1204,7 +1212,7 @@ From the @tech{universe}'s perspective, each @tech{world} is in one of two state @itemize[ @item{A passive @tech{world} is @emph{resting}. We use @scheme['resting] for this state.} @item{An active @tech{world} is not resting. We delay choosing a representation -for this part of a @tech{world}'s state until we design its "local" behavior.} +for this part of a @tech{world}'s state until we design its ``local'' behavior.} ] It is also clear that an active @tech{world} may receive additional messages, which it may ignore. When it is done with its turn, it will send a From 851c58ea50dc31c175bde7016962833f379885c6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Jan 2009 14:00:07 +0000 Subject: [PATCH 28/49] add #:contracts optional sub-form to defform svn: r13012 --- collects/scribble/private/manual-form.ss | 135 +++++++++++++----- collects/scribblings/quick/quick.scrbl | 2 +- collects/scribblings/reference/for.scrbl | 9 +- .../scribblings/reference/parameters.scrbl | 4 +- collects/scribblings/reference/syntax.scrbl | 25 ++-- collects/scribblings/scribble/manual.scrbl | 39 +++-- .../2htdp/scribblings/universe.scrbl | 105 ++++++++------ 7 files changed, 219 insertions(+), 100 deletions(-) diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss index 76ffc10389..8b348a6bf3 100644 --- a/collects/scribble/private/manual-form.ss +++ b/collects/scribble/private/manual-form.ss @@ -32,6 +32,7 @@ (syntax-case stx () [(_ #:id defined-id #:literals (lit ...) [spec spec1 ...] ([non-term-id non-term-form ...] ...) + #:contracts ([contract-nonterm contract-expr] ...) desc ...) (with-syntax ([new-spec (let loop ([spec #'spec]) @@ -65,57 +66,83 @@ (lambda () (schemeblock0/form non-term-form)) ...) ...) + (list (list (lambda () (scheme contract-nonterm)) + (lambda () (schemeblock0 contract-expr))) + ...) (lambda () (list desc ...)))))] + [(fm #:id defined-id #:literals (lit ...) [spec spec1 ...] + ([non-term-id non-term-form ...] ...) + desc ...) + (syntax/loc stx + (fm #:id defined-id #:literals (lit ...) [spec spec1 ...] + ([non-term-id non-term-form ...] ...) + #:contracts () + desc ...))] [(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) - #'(fm #:id id #:literals () [spec spec1 ...] + (syntax/loc stx + (fm #:id id #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) - desc ...)] + #:contracts () + desc ...))] [(fm #:literals lits [(spec-id . spec-rest) spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) (with-syntax ([(_ _ _ [spec . _] . _) stx]) - #'(fm #:id spec-id #:literals lits [spec spec1 ...] + (syntax/loc stx + (fm #:id spec-id #:literals lits [spec spec1 ...] ([non-term-id non-term-form ...] ...) - desc ...))] + desc ...)))] [(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) - #'(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) - desc ...)])) + (syntax/loc stx + (fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) + desc ...))])) (define-syntax (defform* stx) (syntax-case stx () [(_ #:id id #:literals lits [spec ...] desc ...) - #'(defform*/subs #:id id #:literals lits [spec ...] () desc ...)] + (syntax/loc stx + (defform*/subs #:id id #:literals lits [spec ...] () desc ...))] [(_ #:literals lits [spec ...] desc ...) - #'(defform*/subs #:literals lits [spec ...] () desc ...)] + (syntax/loc stx + (defform*/subs #:literals lits [spec ...] () desc ...))] [(_ [spec ...] desc ...) - #'(defform*/subs [spec ...] () desc ...)])) + (syntax/loc stx + (defform*/subs [spec ...] () desc ...))])) (define-syntax (defform stx) (syntax-case stx () [(_ #:id id #:literals (lit ...) spec desc ...) - #'(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...)] + (syntax/loc stx + (defform*/subs #:id id #:literals (lit ...) [spec] () desc ...))] [(_ #:id id spec desc ...) - #'(defform*/subs #:id id #:literals () [spec] () desc ...)] + (syntax/loc stx + (defform*/subs #:id id #:literals () [spec] () desc ...))] [(_ #:literals (lit ...) spec desc ...) - #'(defform*/subs #:literals (lit ...) [spec] () desc ...)] + (syntax/loc stx + (defform*/subs #:literals (lit ...) [spec] () desc ...))] [(_ spec desc ...) - #'(defform*/subs [spec] () desc ...)])) + (syntax/loc stx + (defform*/subs [spec] () desc ...))])) (define-syntax (defform/subs stx) (syntax-case stx () [(_ #:id id #:literals lits spec subs desc ...) - #'(defform*/subs #:id id #:literals lits [spec] subs desc ...)] + (syntax/loc stx + (defform*/subs #:id id #:literals lits [spec] subs desc ...))] [(_ #:id id spec subs desc ...) - #'(defform*/subs #:id id #:literals () [spec] subs desc ...)] + (syntax/loc stx + (defform*/subs #:id id #:literals () [spec] subs desc ...))] [(_ #:literals lits spec subs desc ...) - #'(defform*/subs #:literals lits [spec] subs desc ...)] + (syntax/loc stx + (defform*/subs #:literals lits [spec] subs desc ...))] [(_ spec subs desc ...) - #'(defform*/subs [spec] subs desc ...)])) + (syntax/loc stx + (defform*/subs [spec] subs desc ...))])) (define-syntax (defform/none stx) (syntax-case stx () - [(_ #:literals (lit ...) spec desc ...) + [(_ #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...) (begin (for-each (lambda (id) (unless (identifier? id) @@ -130,9 +157,16 @@ (*defforms #f '(spec) (list (lambda (ignored) (schemeblock0/form spec))) null null + (list (list (lambda () (scheme contract-id)) + (lambda () (schemeblock0 contract-expr))) + ...) (lambda () (list desc ...)))))] - [(_ spec desc ...) - #'(defform/none #:literals () spec desc ...)])) + [(fm #:literals (lit ...) spec desc ...) + (syntax/loc stx + (fm #:literals (lit ...) spec #:contracts () desc ...))] + [(fm spec desc ...) + (syntax/loc stx + (fm #:literals () spec desc ...))])) (define-syntax (defidform stx) (syntax-case stx () @@ -145,6 +179,7 @@ (list (lambda (x) (make-omitable-paragraph (list x)))) null null + null (lambda () (list desc ...))))])) (define (into-blockquote s) @@ -164,6 +199,7 @@ (define-syntax spec?form/subs (syntax-rules () [(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) + #:contracts ([contract-nonterm contract-expr] ...) desc ...) (with-scheme-variables (lit ...) @@ -175,7 +211,15 @@ (lambda () (schemeblock0/form non-term-form)) ...) ...) - (lambda () (list desc ...))))])) + (list (list (lambda () (scheme contract-nonterm)) + (lambda () (schemeblock0 contract-expr))) + ...) + (lambda () (list desc ...))))] + [(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) + desc ...) + (spec?form/subs has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) + #:contracts () + desc ...)])) (define-syntax specsubform (syntax-rules () @@ -220,7 +264,7 @@ (with-scheme-variables () ([form/maybe (#f spec)]) - (*specsubform 'spec null #f null null (lambda () (list desc ...))))) + (*specsubform 'spec null #f null null null (lambda () (list desc ...))))) (define-syntax schemegrammar (syntax-rules () @@ -258,7 +302,7 @@ (define (meta-symbol? s) (memq s '(... ...+ ?))) -(define (*defforms kw-id forms form-procs subs sub-procs content-thunk) +(define (*defforms kw-id forms form-procs subs sub-procs contract-procs content-thunk) (parameterize ([current-meta-list '(... ...+)]) (make-box-splice (cons @@ -307,10 +351,11 @@ sub-procs)]) (*schemerawgrammars "specgrammar" (map car l) - (map cdr l)))))))))) + (map cdr l)))))))) + (make-contracts-table contract-procs))) (content-thunk))))) -(define (*specsubform form lits form-thunk subs sub-procs content-thunk) +(define (*specsubform form lits form-thunk subs sub-procs contract-procs content-thunk) (parameterize ([current-meta-list '(... ...+)]) (make-blockquote "leftindent" @@ -324,16 +369,18 @@ (if form-thunk (form-thunk) (make-omitable-paragraph (list (to-element form))))))) - (if (null? sub-procs) - null - (list (list flow-empty-line) - (list (make-flow - (list (let ([l (map (lambda (sub) - (map (lambda (f) (f)) sub)) - sub-procs)]) - (*schemerawgrammars "specgrammar" - (map car l) - (map cdr l)))))))))) + (append + (if (null? sub-procs) + null + (list (list flow-empty-line) + (list (make-flow + (list (let ([l (map (lambda (sub) + (map (lambda (f) (f)) sub)) + sub-procs)]) + (*schemerawgrammars "specgrammar" + (map car l) + (map cdr l)))))))) + (make-contracts-table contract-procs)))) (flow-paragraphs (decode-flow (content-thunk))))))) (define (*schemerawgrammars style nonterms clauseses) @@ -374,3 +421,21 @@ (define (*var-sym id) (string->symbol (format "_~a" id))) + +(define (make-contracts-table contract-procs) + (if (null? contract-procs) + null + (append + (list (list flow-empty-line)) + (list (list (make-flow + (map (lambda (c) + (make-table + "argcontract" + (list + (list (to-flow (hspace 2)) + (to-flow ((car c))) + flow-spacer + (to-flow ":") + flow-spacer + (make-flow (list ((cadr c)))))))) + contract-procs))))))) diff --git a/collects/scribblings/quick/quick.scrbl b/collects/scribblings/quick/quick.scrbl index 365c7a4eb0..0f589a42a0 100644 --- a/collects/scribblings/quick/quick.scrbl +++ b/collects/scribblings/quick/quick.scrbl @@ -410,7 +410,7 @@ Modules are named and distributed in various ways: @item{Some modules live relative to other modules, without necessarily belonging to any particular collection or package. - For example, in DrScheme, if save your definitions so far in a + For example, in DrScheme, if you save your definitions so far in a file @filepath{quick.ss} and add the line @schemeblock[(provide rainbow square)] diff --git a/collects/scribblings/reference/for.scrbl b/collects/scribblings/reference/for.scrbl index 66802c81b0..8222f37b6e 100644 --- a/collects/scribblings/reference/for.scrbl +++ b/collects/scribblings/reference/for.scrbl @@ -14,7 +14,8 @@ The @scheme[for] iteration forms are based on SRFI-42 @defform/subs[(for (for-clause ...) body ...+) ([for-clause [id seq-expr] [(id ...) seq-expr] - (code:line #:when guard-expr)])]{ + (code:line #:when guard-expr)]) + #:contracts ([seq-expr sequence?])]{ Iteratively evaluates @scheme[body]. The @scheme[for-clause]s introduce bindings whose scope includes @scheme[body] and that @@ -242,7 +243,11 @@ Like @scheme[for*/fold], but the extra @scheme[orig-datum] is used as the source @defform[(define-sequence-syntax id expr-transform-expr - clause-transform-expr)]{ + clause-transform-expr) + #:contracts + ([expr-transform-expr (or/c (-> identifier?) + (syntax? . -> . syntax?))] + [clause-transform-expr (syntax? . -> . syntax?)])]{ Defines @scheme[id] as syntax. An @scheme[(id . _rest)] form is treated specially when used to generate a sequence in a diff --git a/collects/scribblings/reference/parameters.scrbl b/collects/scribblings/reference/parameters.scrbl index 8a04c40e6f..0c99b660d7 100644 --- a/collects/scribblings/reference/parameters.scrbl +++ b/collects/scribblings/reference/parameters.scrbl @@ -45,7 +45,9 @@ reject a change to the parameter's value. The @scheme[guard] is not applied to the initial @scheme[v].} @defform[(parameterize ((parameter-expr value-expr) ...) - body ...+)]{ + body ...+) + #:contracts + ([parameter-expr parameter?])]{ @guideintro["parameterize"]{@scheme[parameterize]} diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 75baa630ce..77ed5e2701 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -28,9 +28,11 @@ See @secref["fully-expanded"] for the core grammar. Each syntactic form is described by a BNF-like notation that describes a combination of (syntax-wrapped) pairs, symbols, and other data (not a sequence of characters). These grammatical specifications are shown -as follows: +as in the following specification of a @schemekeywordfont{something} +form: -@specsubform[(#, @schemekeywordfont{some-form} id ...)] +@specsubform[(#, @schemekeywordfont{something} id thing-expr ...) + #:contracts ([thing-expr number?])] Within such specifications, @@ -42,26 +44,31 @@ Within such specifications, @item{@scheme[...+] indicates one or more repetitions of the preceding datum.} - @item{italic meta-identifiers play the role of non-terminals; in - particular, + @item{Italic meta-identifiers play the role of non-terminals. Some + meta-identifier names imply syntactic constraints: @itemize{ - @item{a meta-identifier that ends in @scheme[_id] stands for an + @item{A meta-identifier that ends in @scheme[_id] stands for an identifier.} - @item{a meta-identifier that ends in @scheme[_keyword] stands + @item{A meta-identifier that ends in @scheme[_keyword] stands for a keyword.} - @item{a meta-identifier that ends with @scheme[_expr] stands - for a sub-form that is expanded as an expression.} + @item{A meta-identifier that ends with @scheme[_expr] (such as + @scheme[_thing-expr]) stands for a sub-form that is + expanded as an expression.} @item{A meta-identifier that ends with @scheme[_body] stands for a sub-form that is expanded in an internal-definition context (see @secref["intdef-body"]).} - }} } + }} + + @item{Contracts indicate constraints on sub-expression results. For + example, @scheme[_thing-expr #, @elem{:} number?] indicates that + the expression @scheme[_thing-expr] must produce a number.}} @;------------------------------------------------------------------------ @section[#:tag "module"]{Modules: @scheme[module], ...} diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 3518eb1269..535ce73e34 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -387,15 +387,19 @@ can also be defined by a single @scheme[defproc*], for the case that it's best to document a related group of procedures at once.} -@defform/subs[(defform maybe-id maybe-literals form-datum pre-flow ...) +@defform/subs[(defform maybe-id maybe-literals form-datum maybe-contracts + pre-flow ...) ([maybe-id code:blank (code:line #:id id)] [maybe-literals code:blank - (code:line #:literals (literal-id ...))])]{ + (code:line #:literals (literal-id ...))] + [maybe-contracts code:blank + (code:line #:contracts ([subform-datum contract-expr-datum] + ...))])]{ Produces a sequence of flow elements (encapsulated in a @scheme[splice]) to document a syntatic form named by @scheme[id] -whose syntax described by @scheme[form-datum]. If no @scheme[#:id] is used +whose syntax is described by @scheme[form-datum]. If no @scheme[#:id] is used to specify @scheme[id], then @scheme[form-datum] must have the form @scheme[(id . _datum)]. @@ -414,16 +418,24 @@ non-terminal. If @scheme[#:literals] clause is provided, however, instances of the @scheme[literal-id]s are typeset normally (i.e., as determined by the enclosing context). -The typesetting of @scheme[form-datum] preserves the source layout, -like @scheme[schemeblock].} +If a @scheme[#:contracts] clause is provided, each +@scheme[subform-datum] (typically an identifier that serves as a +meta-variable in @scheme[form-datum]) is shown as producing a value +that must satisfy the contract described by @scheme[contract-expr-datum]. -@defform[(defform* maybe-id maybe-literals [form-datum ...+] pre-flow ...)]{ +The typesetting of @scheme[form-datum], @scheme[subform-datum], and +@scheme[contract-expr-datum] preserves the source layout, like +@scheme[schemeblock].} + +@defform[(defform* maybe-id maybe-literals [form-datum ...+] maybe-contracts + pre-flow ...)]{ Like @scheme[defform], but for multiple forms using the same @scheme[_id].} @defform[(defform/subs maybe-id maybe-literals form-datum ([nonterm-id clause-datum ...+] ...) + maybe-contracts pre-flow ...)]{ Like @scheme[defform], but including an auxiliary grammar of @@ -434,12 +446,14 @@ non-terminals shown with the @scheme[_id] form. Each @defform[(defform*/subs maybe-id maybe-literals [form-datum ...] + maybe-contracts pre-flow ...)]{ Like @scheme[defform/subs], but for multiple forms for @scheme[_id].} -@defform[(defform/none maybe-literal form-datum pre-flow ...)]{ +@defform[(defform/none maybe-literal form-datum maybe-contracts + pre-flow ...)]{ Like @scheme[defform], but without registering a definition.} @@ -449,14 +463,16 @@ Like @scheme[defform], but without registering a definition.} Like @scheme[defform], but with a plain @scheme[id] as the form.} -@defform[(specform maybe-literals datum pre-flow ...)]{ +@defform[(specform maybe-literals datum maybe-contracts + pre-flow ...)]{ Like @scheme[defform], but without indexing or registering a definition, and with indenting on the left for both the specification and the @scheme[pre-flow]s.} -@defform[(specsubform maybe-literals datum pre-flow ...)]{ +@defform[(specsubform maybe-literals datum maybe-contracts + pre-flow ...)]{ Similar to @scheme[defform], but without any specific identifier being defined, and the table and flow are typeset indented. This form is @@ -472,13 +488,15 @@ procedure. In this description, a reference to any identifier in @defform[(specsubform/subs maybe-literals datum ([nonterm-id clause-datum ...+] ...) + maybe-contracts pre-flow ...)]{ Like @scheme[specsubform], but with a grammar like @scheme[defform/subs].} -@defform[(specspecsubform maybe-literals datum pre-flow ...)]{ +@defform[(specspecsubform maybe-literals datum maybe-contracts + pre-flow ...)]{ Like @scheme[specsubform], but indented an extra level. Since using @scheme[specsubform] within the body of @scheme[specsubform] already @@ -488,6 +506,7 @@ without nesting a description.} @defform[(specspecsubform/subs maybe-literals datum ([nonterm-id clause-datum ...+] ...) + maybe-contracts pre-flow ...)]{ Like @scheme[specspecsubform], but with a grammar like diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index a0f6cd7983..6609c611b4 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -188,22 +188,24 @@ The design of a world program demands that you come up with a data @itemize[ @item{ -@defform[(on-tick - [tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{ +@defform[(on-tick tick-expr) + #:contracts + ([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{ tell DrScheme to call the @scheme[tick-expr] function on the current world every time the clock ticks. The result of the call becomes the current world. The clock ticks at the rate of 28 times per second.}} @item{ -@defform/none[(on-tick - [tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))] +@defform/none[(on-tick tick-expr rate-expr) + #:contracts + ([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))] [rate-expr natural-number/c])]{ tell DrScheme to call the @scheme[tick-expr] function on the current world every time the clock ticks. The result of the call becomes the current world. The clock ticks at the rate of @scheme[rate-expr].}} -@item{An @tech{KeyEvent} represents key board events, e.g., keys pressed or +@item{A @tech{KeyEvent} represents key board events, e.g., keys pressed or released. @deftech{KeyEvent} : @scheme[(or/c char? symbol?)] @@ -230,8 +232,9 @@ A character is used to signal that the user has hit an alphanumeric @defproc[(key=? [x key-event?][y key-event?]) boolean?]{ compares two @tech{KeyEvent} for equality} -@defform[(on-key - [change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{ +@defform[(on-key change-expr) + #:contracts + ([change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{ tell DrScheme to call @scheme[change-expr] function on the current world and a @tech{KeyEvent} for every keystroke the user of the computer makes. The result of the call becomes the current world. @@ -282,8 +285,9 @@ All @tech{MouseEvent}s are represented via symbols: @defproc[(mouse=? [x mouse-event?][y mouse-event?]) boolean?]{ compares two @tech{KeyEvent} for equality} -@defform[(on-mouse - [clack-expr +@defform[(on-mouse clack-expr) + #:contracts + ([clack-expr (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{World}))])]{ tell DrScheme to call @scheme[clack-expr] on the current world, the current @scheme[x] and @scheme[y] coordinates of the mouse, and and a @@ -297,16 +301,18 @@ All @tech{MouseEvent}s are represented via symbols: @item{ -@defform[(on-draw - [render-expr (-> (unsyntax @tech{World}) scene?)])]{ +@defform[(on-draw render-expr) + #:contracts + ([render-expr (-> (unsyntax @tech{World}) scene?)])]{ tell DrScheme to call the function @scheme[render-expr] whenever the canvas must be drawn. The external canvas is usually re-drawn after DrScheme has dealt with an event. Its size is determined by the size of the first generated @tech{scene}.} -@defform/none[(on-draw - [render-expr (-> (unsyntax @tech{World}) scene?)] +@defform/none[(on-draw render-expr width-expr height-expr) + #:contracts + ([render-expr (-> (unsyntax @tech{World}) scene?)] [width-expr natural-number/c] [height-expr natural-number/c])]{ @@ -317,8 +323,9 @@ All @tech{MouseEvent}s are represented via symbols: @item{ -@defform[(stop-when - [last-world? (-> (unsyntax @tech{World}) boolean?)])]{ +@defform[(stop-when last-world?) + #:contracts + ([last-world? (-> (unsyntax @tech{World}) boolean?)])]{ tell DrScheme to call the @scheme[last-world?] function whenever the canvas is drawn. If this call produces @scheme[true], the world program is shut down. Specifically, the clock is stopped; no more @@ -328,8 +335,9 @@ All @tech{MouseEvent}s are represented via symbols: @item{ -@defform[(record? - [boolean-expr boolean?])]{ +@defform[(record? boolean-expr) + #:contracts + ([boolean-expr boolean?])]{ tell DrScheme to record all events and to enable a replay of the entire interaction. The replay action also generates one png image per scene and an animated gif for the entire sequence. @@ -728,21 +736,25 @@ Each world-producing callback in a world program---those for handling clock As mentioned, all event handlers may return @tech{World}s or @tech{Package}s; here are the revised specifications: -@defform/none[(on-tick - [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{ +@defform/none[(on-tick tick-expr) + #:contracts + ([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{ } -@defform/none[(on-tick - [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))] +@defform/none[(on-tick tick-expr rate-expr) + #:contracts + ([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))] [rate-expr natural-number/c])]{ } -@defform/none[(on-key - [change (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{ +@defform/none[(on-key change-expr) + #:contracts + ([change-expr (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{ } -@defform/none[(on-mouse - [clack +@defform/none[(on-mouse clack-expr) + #:contracts + ([clack-expr (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (or/c (unsyntax @tech{World}) package?))])]{ } @@ -780,14 +792,16 @@ following shapes: @itemize[ @item{ -@defform[(register [ip-expr string?])]{ +@defform[(register ip-expr) #:contracts ([ip-expr string?])]{ connect this world to a universe server at the specified @scheme[ip-expr] address and set up capabilities for sending and receiving messages.} } @item{ -@defform/none[(register [ip-expr string?] - [name-expr (or/c symbol? string?)])]{ +@defform/none[(register ip-expr name-expr) + #:contracts + ([ip-expr string?] + [name-expr (or/c symbol? string?)])]{ connect this world to a universe server @emph{under a specific} @scheme[name-expr].} } @@ -807,8 +821,9 @@ Finally, the receipt of a message from the server is an event, just like The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handler for message receipts. -@defform[(on-receive - [receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{ +@defform[(on-receive receive-expr) + #:contracts + ([receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{ tell DrScheme to call @scheme[receive-expr] for every message receipt, on the current @tech{World} and the received message. The result of the call becomes the current @tech{World}. @@ -993,15 +1008,17 @@ description. Two of them are mandatory: @itemize[ @item{ - @defform[(on-new - [new-expr (-> (unsyntax @tech{Universe}) world? + @defform[(on-new new-expr) + #:contracts + ([new-expr (-> (unsyntax @tech{Universe}) world? (cons (unsyntax @tech{Universe}) [listof mail?]))])]{ tell DrScheme to call the function @scheme[new-expr] every time another world joins the universe.}} @item{ - @defform[(on-msg - [msg-expr (-> (unsyntax @tech{Universe}) world? sexp? + @defform[(on-msg msg-expr) + #:contracts + ([msg-expr (-> (unsyntax @tech{Universe}) world? sexp? (cons (unsyntax @tech{Universe}) [listof mail?]))])]{ tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world @@ -1020,15 +1037,17 @@ optional handlers: @itemize[ @item{ -@defform/none[(on-tick - [tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{ +@defform/none[(on-tick tick-expr) + #:contracts + ([tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{ tell DrScheme to apply @scheme[tick-expr] to the current state of the universe. The handler is expected to produce a bundle of the new state of the universe and a list of mails. } -@defform/none[(on-tick - [tick-expr (-> (unsyntax @tech{Universe}) bundle?)] +@defform/none[(on-tick tick-expr rate-expr) + #:contracts + ([tick-expr (-> (unsyntax @tech{Universe}) bundle?)] [rate-expr natural-number/c])]{ tell DrScheme to apply @scheme[tick-expr] as above but use the specified clock tick rate instead of the default. @@ -1036,8 +1055,9 @@ optional handlers: } @item{ - @defform[(on-disconnect - [dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{ + @defform[(on-disconnect dis-expr) + #:contracts + ([dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{ tell DrScheme to invoke @scheme[dis-expr] every time a participating @tech{world} drops its connection to the server. The first argument is the current state of the universe; the second one is the world that got @@ -1046,8 +1066,9 @@ optional handlers: } @item{ - @defform[(to-string - [render-expr (-> (unsyntax @tech{Universe}) string?)])]{ + @defform[(to-string render-expr) + #:contracts + ([render-expr (-> (unsyntax @tech{Universe}) string?)])]{ tell DrScheme to render the state of the universe after each event and to display this string in the universe console. } From 104447edf69069ca1019472ac7c884db52d011fe Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Mon, 5 Jan 2009 14:26:04 +0000 Subject: [PATCH 29/49] Support for collecing per-case test coverage of reduction relations. svn: r13013 --- collects/redex/private/reduction-semantics.ss | 53 +++++++++++++------ collects/redex/private/tl-test.ss | 31 +++++++++++ 2 files changed, 69 insertions(+), 15 deletions(-) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 18aa7ef857..73cc3ad64c 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -754,22 +754,40 @@ (rewrite-proc-name child-make-proc) (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from))) +(define relation-coverage (make-parameter #f)) + +(define-struct covered-case (name apps) #:inspector (make-inspector)) + +(define (apply-case c) + (struct-copy covered-case c [apps (add1 (covered-case-apps c))])) + +(define (cover-case id name relation-coverage) + (hash-update! relation-coverage id apply-case (make-covered-case name 0))) + +(define (covered-cases relation-coverage) + (hash-map relation-coverage (λ (k v) v))) + +(define fresh-coverage make-hasheq) + (define (do-leaf-match name pat w/extras proc) - (make-rewrite-proc - (λ (lang) - (let ([cp (compile-pattern lang pat #t)]) - (λ (main-exp exp f other-matches) - (let ([mtchs (match-pattern cp exp)]) - (if mtchs - (map/mt (λ (mtch) - (let ([really-matched (proc main-exp (mtch-bindings mtch))]) - (and really-matched - (list name (f (successful-result really-matched)))))) - mtchs - other-matches) - other-matches))))) - name - w/extras)) + (let ([case-id (gensym)]) + (make-rewrite-proc + (λ (lang) + (let ([cp (compile-pattern lang pat #t)]) + (λ (main-exp exp f other-matches) + (let ([mtchs (match-pattern cp exp)]) + (if mtchs + (map/mt (λ (mtch) + (let ([really-matched (proc main-exp (mtch-bindings mtch))]) + (and really-matched + (when (relation-coverage) + (cover-case case-id name (relation-coverage))) + (list name (f (successful-result really-matched)))))) + mtchs + other-matches) + other-matches))))) + name + w/extras))) (define-syntax (test-match stx) (syntax-case stx () @@ -1801,3 +1819,8 @@ apply-reduction-relation* variable-not-in variables-not-in) + +(provide relation-coverage + covered-cases + fresh-coverage + (struct-out covered-case)) \ No newline at end of file diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index b26f028fc9..0bbb62e414 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -1,5 +1,8 @@ (module tl-test mzscheme (require "../reduction-semantics.ss" + (only "reduction-semantics.ss" + relation-coverage fresh-coverage covered-cases + make-covered-case covered-case-name) "test-util.ss" (only "matcher.ss" make-bindings make-bind) scheme/match @@ -1161,4 +1164,32 @@ [else #f]) #t)) + (let ([R (reduction-relation + empty-language + (--> number (q ,(add1 (term number))) + (side-condition (odd? (term number))) + side-condition) + (--> 1 4 + one) + (==> 2 t + shortcut) + with + [(--> (q a) b) + (==> a b)])] + [c (fresh-coverage)]) + (parameterize ([relation-coverage c]) + (apply-reduction-relation R 4) + (test (covered-cases c) null) + + (apply-reduction-relation R 3) + (test (covered-cases c) + (list (make-covered-case "side-condition" 1))) + + (apply-reduction-relation* R 1) + (test (sort (covered-cases c) + (λ (c d) (string Date: Mon, 5 Jan 2009 15:54:18 +0000 Subject: [PATCH 30/49] html-spec -> html-spec.ss svn: r13014 --- collects/html/generate-code.ss | 5 ++--- collects/html/html-spec | 1 - collects/html/html-spec.ss | 6 ++++++ collects/html/html-unit.ss | 3 ++- 4 files changed, 10 insertions(+), 5 deletions(-) delete mode 100644 collects/html/html-spec create mode 100644 collects/html/html-spec.ss diff --git a/collects/html/generate-code.ss b/collects/html/generate-code.ss index c02931687f..02b4a9445c 100644 --- a/collects/html/generate-code.ss +++ b/collects/html/generate-code.ss @@ -2,13 +2,12 @@ (require mzlib/pretty mzlib/date mzlib/list - mzlib/etc) + mzlib/etc + "html-spec.ss") ; date-string : -> String (define (date-string) (date->string (seconds->date (current-seconds)) 'seconds-please)) -(define html-spec (call-with-input-file (build-path (collection-path "html") "html-spec") read)) - (define (empty-name? x) (null? (cdr x))) (define empty-names diff --git a/collects/html/html-spec b/collects/html/html-spec deleted file mode 100644 index cc3d423352..0000000000 --- a/collects/html/html-spec +++ /dev/null @@ -1 +0,0 @@ -(((mzscheme) pcdata) ((html) body head) ((div center blockquote ins del dd li th td iframe noframes noscript) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((style script) cdata) ((basefont br area link img param hr input col isindex base meta)) ((option textarea title) pcdata) ((head) base isindex link meta object script style title) ((tr) td th) ((colgroup) col) ((thead tfoot tbody) tr) ((tt i b u s strike big small em strong dfn code samp kbd var cite abbr acronym sub sup span bdo font p h1 h2 h3 h4 h5 h6 q dt legend caption) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((table) caption col colgroup tbody tfoot thead) ((button) abbr acronym address applet b basefont bdo big blockquote br center cite code dfn dir div dl em font h1 h2 h3 h4 h5 h6 hr i img kbd map menu noframes noscript object ol p pcdata pre q s samp script small span strike strong sub sup table tt u ul var) ((fieldset) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label legend map menu noframes noscript object ol p pcdata pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((optgroup) option) ((select) optgroup option) ((label) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((form) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((ol ul dir menu) li) ((dl) dd dt) ((pre) a abbr acronym b bdo br button cite code dfn em i iframe input kbd label map pcdata q s samp script select span strike strong textarea tt u var) ((object applet) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p param pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((map) address area blockquote center dir div dl fieldset form h1 h2 h3 h4 h5 h6 hr isindex menu noframes noscript ol p pre table ul) ((a) abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((address) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object p pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((body) a abbr acronym address applet b basefont bdo big blockquote br button center cite code del dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input ins isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var)) \ No newline at end of file diff --git a/collects/html/html-spec.ss b/collects/html/html-spec.ss new file mode 100644 index 0000000000..efa8a200bd --- /dev/null +++ b/collects/html/html-spec.ss @@ -0,0 +1,6 @@ +#lang scheme/base + +(provide html-spec) + +(define html-spec + '(((mzscheme) pcdata) ((html) body head) ((div center blockquote ins del dd li th td iframe noframes noscript) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((style script) cdata) ((basefont br area link img param hr input col isindex base meta)) ((option textarea title) pcdata) ((head) base isindex link meta object script style title) ((tr) td th) ((colgroup) col) ((thead tfoot tbody) tr) ((tt i b u s strike big small em strong dfn code samp kbd var cite abbr acronym sub sup span bdo font p h1 h2 h3 h4 h5 h6 q dt legend caption) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((table) caption col colgroup tbody tfoot thead) ((button) abbr acronym address applet b basefont bdo big blockquote br center cite code dfn dir div dl em font h1 h2 h3 h4 h5 h6 hr i img kbd map menu noframes noscript object ol p pcdata pre q s samp script small span strike strong sub sup table tt u ul var) ((fieldset) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label legend map menu noframes noscript object ol p pcdata pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((optgroup) option) ((select) optgroup option) ((label) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((form) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((ol ul dir menu) li) ((dl) dd dt) ((pre) a abbr acronym b bdo br button cite code dfn em i iframe input kbd label map pcdata q s samp script select span strike strong textarea tt u var) ((object applet) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p param pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((map) address area blockquote center dir div dl fieldset form h1 h2 h3 h4 h5 h6 hr isindex menu noframes noscript ol p pre table ul) ((a) abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((address) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object p pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((body) a abbr acronym address applet b basefont bdo big blockquote br button center cite code del dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input ins isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var))) diff --git a/collects/html/html-unit.ss b/collects/html/html-unit.ss index 6406d6773a..ce4927b3dc 100644 --- a/collects/html/html-unit.ss +++ b/collects/html/html-unit.ss @@ -6,6 +6,7 @@ mzlib/list mzlib/etc mzlib/include + "html-spec.ss" "html-sig.ss" "sgml-reader-sig.ss" xml/xml-sig) @@ -118,7 +119,7 @@ ;; may-contain : Kid-lister (define may-contain - (sgml:gen-may-contain (call-with-input-file (find-library "html-spec" "html") read))) + (sgml:gen-may-contain html-spec)) (define may-contain-anything (sgml:gen-may-contain null)) From f5c77109fae97cd76d1a31d3c6dcdd2d7425467c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Jan 2009 08:50:08 +0000 Subject: [PATCH 31/49] Welcome to a new PLT day. svn: r13015 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index bfa215a4ee..4599b43c3d 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "5jan2009") +#lang scheme/base (provide stamp) (define stamp "6jan2009") From 61685c72f9f4dc9c759011c02c013ee92ea185be Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Jan 2009 13:07:45 +0000 Subject: [PATCH 32/49] revised Mac OS X sleeping; optional atomic mode for FFI callbacks svn: r13016 --- collects/mzlib/foreign.ss | 19 ++-- collects/scribblings/foreign/types.scrbl | 14 ++- collects/scribblings/foreign/unexported.scrbl | 3 +- src/foreign/foreign.c | 8 +- src/foreign/foreign.ssc | 12 +- src/mred/mredmac.cxx | 96 +--------------- src/mzscheme/include/mzscheme.exp | 4 + src/mzscheme/include/mzscheme3m.exp | 4 + src/mzscheme/include/mzwin.def | 4 + src/mzscheme/include/mzwin3m.def | 4 + src/mzscheme/src/mzstkchk.h | 8 +- src/mzscheme/src/port.c | 105 ++++++++++++++++++ src/mzscheme/src/schemef.h | 5 + src/mzscheme/src/schemex.h | 4 + src/mzscheme/src/schemex.inc | 4 + src/mzscheme/src/schemexm.h | 4 + src/mzscheme/src/schpriv.h | 2 + src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/thread.c | 20 +++- 19 files changed, 213 insertions(+), 111 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 4d999cebbe..87c1b45b57 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -468,17 +468,20 @@ ;; optionally applying a wrapper function to modify the result primitive ;; (callouts) or the input procedure (callbacks). (define* (_cprocedure itypes otype - #:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f]) - (_cprocedure* itypes otype abi wrapper keep)) + #:abi [abi #f] + #:wrapper [wrapper #f] + #:keep [keep #f] + #:atomic? [atomic? #f]) + (_cprocedure* itypes otype abi wrapper keep atomic?)) ;; for internal use (define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper keep) +(define (_cprocedure* itypes otype abi wrapper keep atomic?) (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) (and x - (let ([cb (ffi-callback (wrap x) itypes otype abi)]) + (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)]) (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] [(box? keep) (let ([x (unbox keep)]) @@ -514,6 +517,7 @@ (define xs #f) (define abi #f) (define keep #f) + (define atomic? #f) (define inputs #f) (define output #f) (define bind '()) @@ -578,9 +582,10 @@ (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] ... [else (err "unknown keyword" (car xs))])) - (when (keyword? k) (kwds [#:abi abi] [#:keep keep])))) + (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?])))) (unless abi (set! abi #'#f)) (unless keep (set! keep #'#t)) + (unless atomic? (set! atomic? #'#f)) ;; parse known punctuation (set! xs (map (lambda (x) (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) @@ -671,9 +676,9 @@ (string->symbol (string-append "ffi-wrapper:" n))) body))]) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi (lambda (ffi) #,body) #,keep)) + #,abi (lambda (ffi) #,body) #,keep #,atomic?)) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi #f #,keep))) + #,abi #f #,keep #,atomic?))) (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index e894102004..6c8ee4e944 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -297,6 +297,7 @@ and normally @scheme[_cprocedure] should be used instead of @defproc[(_cprocedure [input-types (list ctype?)] [output-type ctype?] [#:abi abi (or/c symbol/c #f) #f] + [#:atomic? atomic? any/c #f] [#:wrapper wrapper (or/c #f (procedure? . -> . procedure?)) #f] [#:keep keep (or/c boolean? box? (any/c . -> . any/c)) @@ -328,6 +329,16 @@ platform-dependent default; other possible values are ``cdecl''). This is especially important on Windows, where most system functions are @scheme['stdcall], which is not the default. +If @scheme[atomic?] is true, then when a Scheme procedure is given +this procedure type and called from foreign code, then the PLT Scheme +virtual machine is put into atomic mode while evaluating the Scheme +procedure body. In atomic mode, other Scheme threads cannot run, so +the Scheme code must not call any function that potentially +synchronizes with other threads (including I/O functions). In +addition, the Scheme code must not raise an uncaught exception, it +must not perform any escaping continuation jumps, and its non-tail +recursion must be minimal to avoid C-level stack overflow. + The optional @scheme[wrapper], if provided, is expected to be a function that can change a callout procedure: when a callout is generated, the wrapper is applied on the newly created primitive @@ -394,7 +405,8 @@ values: @itemize[ (_fun fun-option ... maybe-args type-spec ... -> type-spec maybe-wrapper) ([fun-option (code:line #:abi abi-expr) - (code:line #:keep keep-expr)] + (code:line #:keep keep-expr) + (code:line #:atomic? atomic?-expr)] [maybe-args code:blank (code:line (id ...) ::) (code:line id ::) diff --git a/collects/scribblings/foreign/unexported.scrbl b/collects/scribblings/foreign/unexported.scrbl index a4631b9343..3b2a81e303 100644 --- a/collects/scribblings/foreign/unexported.scrbl +++ b/collects/scribblings/foreign/unexported.scrbl @@ -62,7 +62,8 @@ especially important on Windows, where most system functions are @defproc[(ffi-callback [proc any/c] [in-types any/c] [out-type any/c] - [abi (or/c symbol/c #f) #f]) + [abi (or/c symbol/c #f) #f] + [atomic? any/c #f]) ffi-callback?]{ The symmetric counterpart of @scheme[ffi-call]. It receives a Scheme diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 155e4e7716..7e312b9b3f 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -1108,6 +1108,7 @@ typedef struct ffi_callback_struct { Scheme_Object* proc; Scheme_Object* itypes; Scheme_Object* otype; + int call_in_scheduler; } ffi_callback_struct; #define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag) #undef MYNAME @@ -2580,12 +2581,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) argv = argv_stack; else argv = scheme_malloc(argc * sizeof(Scheme_Object*)); + if (data->call_in_scheduler) + scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); + if (data->call_in_scheduler) + scheme_end_in_scheduler(); } /* see ffi-callback below */ @@ -2688,6 +2693,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) data->proc = (argv[0]); data->itypes = (argv[1]); data->otype = (argv[2]); + data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4]))); #ifdef MZ_PRECISE_GC { /* put data in immobile, weak box */ @@ -2853,7 +2859,7 @@ void scheme_init_foreign(Scheme_Env *env) scheme_add_global("ffi-call", scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv); scheme_add_global("ffi-callback", - scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv); + scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), menv); s = scheme_intern_symbol("void"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index da91591339..37bc900f46 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -944,7 +944,8 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) (callback "void*") (proc "Scheme_Object*") (itypes "Scheme_Object*") - (otype "Scheme_Object*")):} + (otype "Scheme_Object*") + (call_in_scheduler "int")):} /*****************************************************************************/ /* Pointer objects */ @@ -1969,12 +1970,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) argv = argv_stack; else argv = scheme_malloc(argc * sizeof(Scheme_Object*)); + if (data->call_in_scheduler) + scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); + if (data->call_in_scheduler) + scheme_end_in_scheduler(); } /* see ffi-callback below */ @@ -2005,7 +2010,7 @@ void free_cl_cif_args(void *ignored, void *p) /* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ -{:(cdefine ffi-callback 3 4):} +{:(cdefine ffi-callback 3 5):} { ffi_callback_struct *data; Scheme_Object *itypes = argv[1]; @@ -2070,7 +2075,8 @@ void free_cl_cif_args(void *ignored, void *p) if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); {:(cmake-object "data" ffi-callback - "cl_cif_args" "argv[0]" "argv[1]" "argv[2]"):} + "cl_cif_args" "argv[0]" "argv[1]" "argv[2]" + "((argc > 4) && SCHEME_TRUEP(argv[4]))"):} #ifdef MZ_PRECISE_GC { /* put data in immobile, weak box */ diff --git a/src/mred/mredmac.cxx b/src/mred/mredmac.cxx index 5597a470d9..5a1fa02ae5 100644 --- a/src/mred/mredmac.cxx +++ b/src/mred/mredmac.cxx @@ -1179,103 +1179,20 @@ int MrEdCheckForBreak(void) /***************************************************************************/ #include -static volatile int thread_running; -static volatile int need_post; /* 0=>1 transition has a benign race condition, an optimization */ -static SLEEP_PROC_PTR mzsleep; -static pthread_t watcher; -static volatile float sleep_secs; -/* These file descriptors act as semaphores: */ -static int watch_read_fd, watch_write_fd; -static int watch_done_read_fd, watch_done_write_fd; - -/* These file descriptors are used for breaking the event loop. - See ARGH below. */ +/* These file descriptors are used for breaking the event loop. */ static int cb_socket_ready; static int ready_sock, write_ready_sock; -#ifdef MZ_PRECISE_GC -START_XFORM_SKIP; -#endif - -static void *do_watch(void *fds) -{ - while (1) { - char buf[1]; - - read(watch_read_fd, buf, 1); - - mzsleep(sleep_secs, fds); - if (need_post) { - need_post = 0; - if (cb_socket_ready) { - /* Sometimes WakeUpProcess() doesn't work. - Try a notification socket as a backup. - See ARGH below. */ - write(write_ready_sock, "y", 1); - } - } - - write(watch_done_write_fd, "y", 1); - } - - return NULL; -} - -#ifdef MZ_PRECISE_GC -END_XFORM_SKIP; -#endif - static int StartFDWatcher(void (*mzs)(float secs, void *fds), float secs, void *fds) { - if (!watch_write_fd) { - int fds[2]; - if (!pipe(fds)) { - watch_read_fd = fds[0]; - watch_write_fd = fds[1]; - } else { - return 0; - } - } - - if (!watch_done_write_fd) { - int fds[2]; - if (!pipe(fds)) { - watch_done_read_fd = fds[0]; - watch_done_write_fd = fds[1]; - } else { - return 0; - } - } - - if (!watcher) { - if (pthread_create(&watcher, NULL, do_watch, fds)) { - return 0; - } - } - - mzsleep = mzs; - sleep_secs = secs; - thread_running = 1; - need_post = 1; - write(watch_write_fd, "x", 1); - + scheme_start_sleeper_thread(mzs, secs, fds, write_ready_sock); return 1; } static void EndFDWatcher(void) { - char buf[1]; - - if (thread_running) { - if (need_post) { - need_post = 0; - scheme_signal_received(); - } - - read(watch_done_read_fd, buf, 1); - thread_running = 0; - } + scheme_end_sleeper_thread(); } void socket_callback(CFSocketRef s, CFSocketCallBackType type, CFDataRef address, const void *data, void *info) @@ -1369,11 +1286,8 @@ void MrEdMacSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep) going++; - if (need_post) /* useless check in principle, but an optimization - in the case that the select() succeeds before - we even start */ - if (WNE(&e, secs ? secs : kEventDurationForever)) - QueueTransferredEvent(&e); + if (WNE(&e, secs ? secs : kEventDurationForever)) + QueueTransferredEvent(&e); --going; diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index 2964103272..2c28fd9017 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -23,6 +23,8 @@ scheme_get_current_thread scheme_start_atomic scheme_end_atomic scheme_end_atomic_no_swap +scheme_start_in_scheduler +scheme_end_in_scheduler scheme_out_of_fuel scheme_thread scheme_thread_w_details @@ -43,6 +45,8 @@ scheme_wait_input_allowed scheme_unless_ready scheme_in_main_thread scheme_cancel_sleep +scheme_start_sleeper_thread +scheme_end_sleeper_thread scheme_make_thread_cell scheme_thread_cell_get scheme_thread_cell_set diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index 06551c05c3..23666cd019 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -23,6 +23,8 @@ scheme_get_current_thread scheme_start_atomic scheme_end_atomic scheme_end_atomic_no_swap +scheme_start_in_scheduler +scheme_end_in_scheduler scheme_out_of_fuel scheme_thread scheme_thread_w_details @@ -43,6 +45,8 @@ scheme_wait_input_allowed scheme_unless_ready scheme_in_main_thread scheme_cancel_sleep +scheme_start_sleeper_thread +scheme_end_sleeper_thread scheme_make_thread_cell scheme_thread_cell_get scheme_thread_cell_set diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index 10c2121d96..55296444a6 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -25,6 +25,8 @@ EXPORTS scheme_start_atomic scheme_end_atomic scheme_end_atomic_no_swap + scheme_start_in_scheduler + scheme_end_in_scheduler scheme_out_of_fuel scheme_thread scheme_thread_w_details @@ -45,6 +47,8 @@ EXPORTS scheme_unless_ready scheme_in_main_thread scheme_cancel_sleep + scheme_start_sleeper_thread + scheme_end_sleeper_thread scheme_make_thread_cell scheme_thread_cell_get scheme_thread_cell_set diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index dedbc0d149..c3f9ee33a4 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -25,6 +25,8 @@ EXPORTS scheme_start_atomic scheme_end_atomic scheme_end_atomic_no_swap + scheme_start_in_scheduler + scheme_end_in_scheduler scheme_out_of_fuel scheme_thread scheme_thread_w_details @@ -45,6 +47,8 @@ EXPORTS scheme_unless_ready scheme_in_main_thread scheme_cancel_sleep + scheme_start_sleeper_thread + scheme_end_sleeper_thread scheme_make_thread_cell scheme_thread_cell_get scheme_thread_cell_set diff --git a/src/mzscheme/src/mzstkchk.h b/src/mzscheme/src/mzstkchk.h index 86ba29c807..c42851f550 100644 --- a/src/mzscheme/src/mzstkchk.h +++ b/src/mzscheme/src/mzstkchk.h @@ -9,10 +9,11 @@ unsigned long _stk_pos; _stk_pos = (unsigned long)&_stk_pos; - if (STK_COMP(_stk_pos, (unsigned long)SCHEME_CURRENT_PROCESS->stack_end)) + if (STK_COMP(_stk_pos, (unsigned long)SCHEME_CURRENT_PROCESS->stack_end) + && !scheme_no_stack_overflow) #else # ifdef USE_STACKAVAIL - if (stackavail() < STACK_SAFETY_MARGIN) + if ((stackavail() < STACK_SAFETY_MARGIN) && !scheme_no_stack_overflow) # endif # if defined(UNIX_FIND_STACK_BOUNDS) || defined(WINDOWS_FIND_STACK_BOUNDS) \ || defined(MACOS_FIND_STACK_BOUNDS) || defined(ASSUME_FIXED_STACK_SIZE) \ @@ -22,7 +23,8 @@ _stk_pos = (unsigned long)&_stk_pos; - if (STK_COMP(_stk_pos, SCHEME_STACK_BOUNDARY)) + if (STK_COMP(_stk_pos, SCHEME_STACK_BOUNDARY) + && !scheme_no_stack_overflow) # endif #endif diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 9ef41d395c..9fee6f1361 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -8291,6 +8291,111 @@ void scheme_start_itimer_thread(long usec) #endif + +#ifdef OS_X + +/* Sleep-in-thread support needed for GUIs Mac OS X. + To merge waiting on a CoreFoundation event with a select(), an embedding + application can attach a single socket to an event callback, and then + create a Mac thread to call the usual sleep and write to the socket when + data is available. */ + +#ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +#endif + +typedef struct { + pthread_mutex_t lock; + pthread_cond_t cond; + int count; +} pt_sema_t; + +void pt_sema_init(pt_sema_t *sem) +{ + pthread_mutex_init(&sem->lock, NULL); + pthread_cond_init(&sem->cond, NULL); + sem->count = 0; +} + +void pt_sema_wait(pt_sema_t *sem) +{ + pthread_mutex_lock(&sem->lock); + while (sem->count <= 0) + pthread_cond_wait(&sem->cond, &sem->lock); + sem->count--; + pthread_mutex_unlock(&sem->lock); +} + +void pt_sema_post(pt_sema_t *sem) +{ + pthread_mutex_lock(&sem->lock); + sem->count++; + if (sem->count > 0) + pthread_cond_signal(&sem->cond); + pthread_mutex_unlock(&sem->lock); +} + +static pthread_t watcher; +static pt_sema_t sleeping_sema, done_sema; +static float sleep_secs; +static int slept_fd; +static void *sleep_fds; +static void (*sleep_sleep)(float seconds, void *fds); + +static void *do_watch() +{ + while (1) { + pt_sema_wait(&sleeping_sema); + + sleep_sleep(sleep_secs, sleep_fds); + write(slept_fd, "y", 1); + + pt_sema_post(&done_sema); + } +} + +void scheme_start_sleeper_thread(void (*given_sleep)(float seconds, void *fds), float secs, void *fds, int hit_fd) +{ + if (!watcher) { + pt_sema_init(&sleeping_sema); + pt_sema_init(&done_sema); + + if (pthread_create(&watcher, NULL, do_watch, NULL)) { + scheme_log_abort("pthread_create failed"); + abort(); + } + } + + sleep_sleep = given_sleep; + sleep_fds = fds; + sleep_secs = secs; + slept_fd = hit_fd; + pt_sema_post(&sleeping_sema); +} + +void scheme_end_sleeper_thread() +{ + scheme_signal_received(); + pt_sema_wait(&done_sema); + + /* Clear external event flag */ + if (external_event_fd) { + char buf[10]; + read(external_event_fd, buf, 10); + } +} + +#ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +#endif + +#else + +void scheme_start_sleeper_thread(void *fds, int hit_fd); +void scheme_end_sleeper_thread(); + +#endif + /*========================================================================*/ /* memory debugging help */ /*========================================================================*/ diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index aed0cce1e2..baa6514acd 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -82,6 +82,8 @@ MZ_EXTERN Scheme_Thread *scheme_get_current_thread(); MZ_EXTERN void scheme_start_atomic(void); MZ_EXTERN void scheme_end_atomic(void); MZ_EXTERN void scheme_end_atomic_no_swap(void); +MZ_EXTERN void scheme_start_in_scheduler(void); +MZ_EXTERN void scheme_end_in_scheduler(void); MZ_EXTERN void scheme_out_of_fuel(void); @@ -120,6 +122,9 @@ MZ_EXTERN int scheme_in_main_thread(void); MZ_EXTERN void scheme_cancel_sleep(void); +MZ_EXTERN void scheme_start_sleeper_thread(void (*mzsleep)(float seconds, void *fds), float secs, void *fds, int hit_fd); +MZ_EXTERN void scheme_end_sleeper_thread(); + MZ_EXTERN Scheme_Object *scheme_make_thread_cell(Scheme_Object *def_val, int inherited); MZ_EXTERN Scheme_Object *scheme_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells); MZ_EXTERN void scheme_thread_cell_set(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 49d8794b9b..a6e4966bbe 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -66,6 +66,8 @@ Scheme_Thread *(*scheme_get_current_thread)(); void (*scheme_start_atomic)(void); void (*scheme_end_atomic)(void); void (*scheme_end_atomic_no_swap)(void); +void (*scheme_start_in_scheduler)(void); +void (*scheme_end_in_scheduler)(void); void (*scheme_out_of_fuel)(void); Scheme_Object *(*scheme_thread)(Scheme_Object *thunk); Scheme_Object *(*scheme_thread_w_details)(Scheme_Object *thunk, @@ -95,6 +97,8 @@ void (*scheme_wait_input_allowed)(Scheme_Input_Port *port, int nonblock); int (*scheme_unless_ready)(Scheme_Object *unless); int (*scheme_in_main_thread)(void); void (*scheme_cancel_sleep)(void); +void (*scheme_start_sleeper_thread)(void (*mzsleep)(float seconds, void *fds), float secs, void *fds, int hit_fd); +void (*scheme_end_sleeper_thread)(); Scheme_Object *(*scheme_make_thread_cell)(Scheme_Object *def_val, int inherited); Scheme_Object *(*scheme_thread_cell_get)(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells); void (*scheme_thread_cell_set)(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v); diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index 8be0b9fa93..e18aeab800 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -31,6 +31,8 @@ scheme_extension_table->scheme_start_atomic = scheme_start_atomic; scheme_extension_table->scheme_end_atomic = scheme_end_atomic; scheme_extension_table->scheme_end_atomic_no_swap = scheme_end_atomic_no_swap; + scheme_extension_table->scheme_start_in_scheduler = scheme_start_in_scheduler; + scheme_extension_table->scheme_end_in_scheduler = scheme_end_in_scheduler; scheme_extension_table->scheme_out_of_fuel = scheme_out_of_fuel; scheme_extension_table->scheme_thread = scheme_thread; scheme_extension_table->scheme_thread_w_details = scheme_thread_w_details; @@ -51,6 +53,8 @@ scheme_extension_table->scheme_unless_ready = scheme_unless_ready; scheme_extension_table->scheme_in_main_thread = scheme_in_main_thread; scheme_extension_table->scheme_cancel_sleep = scheme_cancel_sleep; + scheme_extension_table->scheme_start_sleeper_thread = scheme_start_sleeper_thread; + scheme_extension_table->scheme_end_sleeper_thread = scheme_end_sleeper_thread; scheme_extension_table->scheme_make_thread_cell = scheme_make_thread_cell; scheme_extension_table->scheme_thread_cell_get = scheme_thread_cell_get; scheme_extension_table->scheme_thread_cell_set = scheme_thread_cell_set; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index 67411f13bb..20b0998e6c 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -31,6 +31,8 @@ #define scheme_start_atomic (scheme_extension_table->scheme_start_atomic) #define scheme_end_atomic (scheme_extension_table->scheme_end_atomic) #define scheme_end_atomic_no_swap (scheme_extension_table->scheme_end_atomic_no_swap) +#define scheme_start_in_scheduler (scheme_extension_table->scheme_start_in_scheduler) +#define scheme_end_in_scheduler (scheme_extension_table->scheme_end_in_scheduler) #define scheme_out_of_fuel (scheme_extension_table->scheme_out_of_fuel) #define scheme_thread (scheme_extension_table->scheme_thread) #define scheme_thread_w_details (scheme_extension_table->scheme_thread_w_details) @@ -51,6 +53,8 @@ #define scheme_unless_ready (scheme_extension_table->scheme_unless_ready) #define scheme_in_main_thread (scheme_extension_table->scheme_in_main_thread) #define scheme_cancel_sleep (scheme_extension_table->scheme_cancel_sleep) +#define scheme_start_sleeper_thread (scheme_extension_table->scheme_start_sleeper_thread) +#define scheme_end_sleeper_thread (scheme_extension_table->scheme_end_sleeper_thread) #define scheme_make_thread_cell (scheme_extension_table->scheme_make_thread_cell) #define scheme_thread_cell_get (scheme_extension_table->scheme_thread_cell_get) #define scheme_thread_cell_set (scheme_extension_table->scheme_thread_cell_set) diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 71f440ca72..48207e915a 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -362,6 +362,8 @@ extern mz_proc_thread *scheme_master_proc_thread; extern THREAD_LOCAL mz_proc_thread *proc_thread_self; #endif +extern int scheme_no_stack_overflow; + typedef struct Scheme_Thread_Set { Scheme_Object so; struct Scheme_Thread_Set *parent; diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index c5a40ac424..0583c45695 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.3.8" +#define MZSCHEME_VERSION "4.1.3.9" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 8 +#define MZSCHEME_VERSION_W 9 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 7c3460b74b..3ce6f2fab4 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -220,6 +220,7 @@ static int missed_context_switch = 0; static int have_activity = 0; int scheme_active_but_sleeping = 0; static int thread_ended_with_activity; +int scheme_no_stack_overflow; static int needs_sleep_cancelled; @@ -3437,13 +3438,16 @@ static int check_sleep(int need_activity, int sleep_now) { Scheme_Thread *p, *p2; int end_with_act; - + #if defined(USING_FDS) DECL_FDSET(set, 3); fd_set *set1, *set2; #endif void *fds; + if (scheme_no_stack_overflow) + return 0; + /* Is everything blocked? */ if (!do_atomic) { p = scheme_first_thread; @@ -3641,7 +3645,7 @@ static int can_break_param(Scheme_Thread *p) int scheme_can_break(Scheme_Thread *p) { - if (!p->suspend_break) { + if (!p->suspend_break && !scheme_no_stack_overflow) { return can_break_param(p); } else return 0; @@ -4361,6 +4365,18 @@ void scheme_end_atomic_no_swap(void) --do_atomic; } +void scheme_start_in_scheduler(void) +{ + do_atomic++; + scheme_no_stack_overflow++; +} + +void scheme_end_in_scheduler(void) +{ + --do_atomic; + --scheme_no_stack_overflow; +} + void scheme_end_atomic(void) { scheme_end_atomic_no_swap(); From e3040e57993d2ab50cbf262a30e6b39fdf8a7c60 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Jan 2009 13:15:51 +0000 Subject: [PATCH 33/49] fix some non-Mac declarations svn: r13017 --- src/mzscheme/src/port.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 9fee6f1361..beb09cf2a7 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -8391,8 +8391,12 @@ END_XFORM_SKIP; #else -void scheme_start_sleeper_thread(void *fds, int hit_fd); -void scheme_end_sleeper_thread(); +void scheme_start_sleeper_thread(void (*given_sleep)(float seconds, void *fds), float secs, void *fds, int hit_fd) +{ +} +void scheme_end_sleeper_thread() +{ +} #endif From cfbd48a4a446733c3db3cf1ce3a0aced44787f83 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Jan 2009 14:29:00 +0000 Subject: [PATCH 34/49] clarify atomic-function responsibilities svn: r13018 --- collects/scribblings/foreign/types.scrbl | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 6c8ee4e944..cdd5afabc5 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -331,13 +331,15 @@ system functions are @scheme['stdcall], which is not the default. If @scheme[atomic?] is true, then when a Scheme procedure is given this procedure type and called from foreign code, then the PLT Scheme -virtual machine is put into atomic mode while evaluating the Scheme -procedure body. In atomic mode, other Scheme threads cannot run, so -the Scheme code must not call any function that potentially -synchronizes with other threads (including I/O functions). In -addition, the Scheme code must not raise an uncaught exception, it -must not perform any escaping continuation jumps, and its non-tail -recursion must be minimal to avoid C-level stack overflow. +process is put into atomic mode while evaluating the Scheme procedure +body. In atomic mode, other Scheme threads do not run, so the Scheme +code must not call any function that potentially synchronizes with +other threads, otherwise it may deadlock. In addition, the Scheme code +must not perform any potentially blocking operation (such as I/O), it +must not raise an uncaught exception, it must not perform any escaping +continuation jumps, and its non-tail recursion must be minimal to +avoid C-level stack overflow; otherwise, the process may crash or +misbehave. The optional @scheme[wrapper], if provided, is expected to be a function that can change a callout procedure: when a callout is From 110098bc3b0f706ce722428ac9a2f72d88c77461 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 6 Jan 2009 15:36:57 +0000 Subject: [PATCH 35/49] Adding caching note in faq svn: r13019 --- collects/web-server/scribblings/faq.scrbl | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/collects/web-server/scribblings/faq.scrbl b/collects/web-server/scribblings/faq.scrbl index 5cc10d18da..1c1c31d6ca 100644 --- a/collects/web-server/scribblings/faq.scrbl +++ b/collects/web-server/scribblings/faq.scrbl @@ -1,8 +1,20 @@ #lang scribble/doc @(require "web-server.ss") +@(require (for-label web-server/dispatchers/dispatch-servlets)) @title{Troubleshooting and Tips} +@section{Why are my servlets not updating on the server when I change the code on disk?} + +By default, the server uses @scheme[make-cached-url->servlet] to load servlets +from the disk. As it loads them, they are cached and the disk is not referred to for future +requests. This ensures that there is a single namespace for each servlet, so that different instances +can share resources, such as database connections, and communicate through the store. The default +configuration of the server (meaning the dispatcher sequence used when you load a configuration file) +provides a special URL to localhost that will reset the cache: @filepath{/conf/refresh-servlets}. If +you want the server to reload your changed servlet code, then GET this URL and the server will reload the +servlet on the next request. + @section{What special considerations are there for security with the Web Server?} The biggest problem is that a naive usage of continuations will allow continuations to subvert From f5aa64f90bebb821340babd6387f742b8a7e23d2 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 6 Jan 2009 15:37:23 +0000 Subject: [PATCH 36/49] send/formlet issue svn: r13020 --- .../dispatchers/dispatch-servlets-test.ss | 2 ++ .../dispatchers/servlet-test-util.ss | 15 +++++++---- .../htdocs/servlets/examples/add-formlets.ss | 26 +++++++++++++++++++ collects/web-server/formlets/servlet.ss | 16 +++++++++--- .../web-server/scribblings/formlets.scrbl | 10 +++++-- 5 files changed, 58 insertions(+), 11 deletions(-) create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/add-formlets.ss diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index 9716d4b9b9..9546581058 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss @@ -60,6 +60,8 @@ (build-path example-servlets "add-v2.ss")) (test-add-two-numbers mkd "add-ssd.ss - send/suspend/dispatch" (build-path example-servlets "add-ssd.ss")) + (test-add-two-numbers mkd "add-ssd.ss - send/formlet" + (build-path example-servlets "add-formlets.ss")) (test-equal? "count.ss - state" (let* ([d (mkd (build-path example-servlets "count.ss"))] [ext (lambda (c) diff --git a/collects/tests/web-server/dispatchers/servlet-test-util.ss b/collects/tests/web-server/dispatchers/servlet-test-util.ss index 7b916dbdf1..37db1dfbcf 100644 --- a/collects/tests/web-server/dispatchers/servlet-test-util.ss +++ b/collects/tests/web-server/dispatchers/servlet-test-util.ss @@ -20,11 +20,16 @@ (test-equal? t (let* ([d (mkd p)] - [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))] - [k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs) - (list (make-binding:form #"number" xs)))))] - [n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys) - (list (make-binding:form #"number" ys)))))]) + [r0 (call d url0 empty)] + [k0 (first ((sxpath "//form/@action/text()") r0))] + [i0 (first ((sxpath "//form/input/@name/text()") r0))] + [r1 (call d (format "~a?~a=~a" k0 i0 xs) + (list (make-binding:form (string->bytes/utf-8 i0) xs)))] + [k1 (first ((sxpath "//form/@action/text()") r1))] + [i1 (first ((sxpath "//form/input/@name/text()") r1))] + [r2 (call d (format "~a?~a=~a" k1 i1 ys) + (list (make-binding:form (string->bytes/utf-8 i1) ys)))] + [n (first ((sxpath "//p/text()") r2))]) n) (format "The answer is ~a" (+ x y))))) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/add-formlets.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/add-formlets.ss new file mode 100644 index 0000000000..f7173a76aa --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/add-formlets.ss @@ -0,0 +1,26 @@ +#lang scheme +(require web-server/servlet + web-server/formlets) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +; request-number : str -> num +(define (request-number which-number) + (send/formlet + (formlet + (#%# "Enter the " ,which-number " number to add: " + ,{input-int . => . the-number} + (input ([type "submit"] [name "enter"] [value "Enter"]))) + the-number) + #:wrap + (lambda (f-expr) + `(html (head (title "Enter a Number to Add")) + (body ([bgcolor "white"]) + ,f-expr))))) + +(define (start initial-request) + `(html (head (title "Sum")) + (body ([bgcolor "white"]) + (p "The answer is " + ,(number->string (+ (request-number "first") (request-number "second"))))))) diff --git a/collects/web-server/formlets/servlet.ss b/collects/web-server/formlets/servlet.ss index e6d97a0f14..2e1230ec0f 100644 --- a/collects/web-server/formlets/servlet.ss +++ b/collects/web-server/formlets/servlet.ss @@ -4,15 +4,23 @@ "lib.ss") (provide/contract - [send/formlet ((formlet/c any/c) . -> . any/c)]) + [send/formlet (((formlet/c any/c)) + (#:wrap (xexpr? . -> . response?)) + . ->* . any/c)]) -(define (send/formlet f) +(define (send/formlet f + #:wrap + [wrapper + (lambda (form-xexpr) + `(html (head (title "Form Entry")) + (body ,form-xexpr)))]) (formlet-process f (send/suspend (lambda (k-url) - `(form ([action ,k-url]) - ,@(formlet-display f)))))) + (wrapper + `(form ([action ,k-url]) + ,@(formlet-display f))))))) (provide/contract [embed-formlet (embed/url/c (formlet/c any/c) . -> . xexpr?)]) diff --git a/collects/web-server/scribblings/formlets.scrbl b/collects/web-server/scribblings/formlets.scrbl index 07337d67df..e3e865eaa9 100644 --- a/collects/web-server/scribblings/formlets.scrbl +++ b/collects/web-server/scribblings/formlets.scrbl @@ -226,10 +226,16 @@ There are a few basic @tech{formlet}s provided by this library. A few utilities are provided for using @tech{formlet}s in Web applications. -@defproc[(send/formlet [f (formlet/c any/c)]) +@defproc[(send/formlet [f (formlet/c any/c)] + [#:wrap wrapper + (xexpr? . -> . response?) + (lambda (form-xexpr) + `(html (head (title "Form Entry")) + (body ,form-xexpr)))]) any/c]{ Uses @scheme[send/suspend] to send @scheme[f]'s rendering (wrapped in a FORM tag whose action is - the continuation URL) to the client. When the form is submitted, the request is passed to the + the continuation URL (wrapped again by @scheme[wrapper])) to the client. + When the form is submitted, the request is passed to the processing stage of @scheme[f]. } From 9281b6f2b566adfee9ceb2325d9f2f4671dba640 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 6 Jan 2009 15:55:34 +0000 Subject: [PATCH 37/49] Clarifying docs and adding test svn: r13021 --- collects/xml/test.ss | 28 ++++++++++++++++++++++++++-- collects/xml/xml.scrbl | 6 +++--- 2 files changed, 29 insertions(+), 5 deletions(-) diff --git a/collects/xml/test.ss b/collects/xml/test.ss index c2f1c57a29..e0f0fc43fa 100644 --- a/collects/xml/test.ss +++ b/collects/xml/test.ss @@ -2,7 +2,8 @@ ;; % mzscheme --require test.ss (module test mzscheme - (require xml/xml) + (require xml/xml + scheme/port) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -66,7 +67,7 @@ ;; permissive? (with-handlers ([exn? (lambda (exn) - (regexp-match #rx"Expected content," (exn-message exn)))]) + (regexp-match #rx"Expected content," (exn-message exn)))]) (report-err "Non-permissive" (xml->xexpr #f) "Exception")) (with-handlers ([exn? @@ -77,6 +78,29 @@ (when tmp (report-err "Permissive" tmp "#f"))))) + ;; doctype + (let () + (define source-string #< + +END + ) + + (define source-document + (read-xml (open-input-string source-string))) + (define result-string + (with-output-to-string (lambda () (write-xml source-document)))) + (define expected-string #< +END + ) + (unless (string=? expected-string result-string) + (report-err "DOCTYPE dropping" + result-string + expected-string))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; done diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index dc89b9042d..e8f14dd0fc 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -23,9 +23,9 @@ generating XML. XML can be represented as an instance of the @scheme[document] structure type, or as a kind of S-expression that is called an @deftech{X-expression}. -The @schememodname[xml] library does not provides Document Type -Declaration (DTD) processing, validation, expanding user-defined -entities, or reading user-defined entities in attributes. +The @schememodname[xml] library does not provide Document Type +Declaration (DTD) processing, including preservation of DTDs in read documents, or validation. +It also does not expand user-defined entities or read user-defined entities in attributes. @; ---------------------------------------------------------------------- From 090c73647fc6b0ca34e7c93e5ec59601ca6ff498 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Jan 2009 19:52:40 +0000 Subject: [PATCH 38/49] atomic mode for objc methods; doc tweaks svn: r13022 --- collects/ffi/objc.scrbl | 14 ++++++++------ collects/ffi/objc.ss | 15 ++++++++++----- collects/scribblings/foreign/types.scrbl | 2 +- collects/scribblings/reference/booleans.scrbl | 4 +++- 4 files changed, 22 insertions(+), 13 deletions(-) diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl index e4564f6161..6a5d0c810a 100644 --- a/collects/ffi/objc.scrbl +++ b/collects/ffi/objc.scrbl @@ -118,13 +118,13 @@ Defines each @scheme[class-id] to the class (a value with FFI type (eval:alts (import-class NSString) (void)) ]} -@defform/subs[#:literals (+ -) +@defform/subs[#:literals (+ - +a -a) (define-objc-class class-id superclass-expr [field-id ...] method) ([method (mode result-ctype-expr (method-id) body ...+) (mode result-ctype-expr (arg ...+) body ...+)] - [mode + -] + [mode + - +a -a] [arg (code:line method-id [ctype-expr arg-id])])]{ Defines @scheme[class-id] as a new, registered Objective-C class (of @@ -138,10 +138,12 @@ directly when the method @scheme[body]s. Outside the object, they can be referenced and set with @scheme[get-ivar] and @scheme[set-ivar!]. Each @scheme[method] adds or overrides a method to the class (when -@scheme[mode] is @scheme[-]) to be called on instances, or it adds a -method to the meta-class (when @scheme[mode] is @scheme[+]) to be -called on the class itself. All result and argument types must be -declared using FFI C types (@seeCtype). +@scheme[mode] is @scheme[-] or @scheme[-a]) to be called on instances, +or it adds a method to the meta-class (when @scheme[mode] is +@scheme[+] or @scheme[+a]) to be called on the class itself. All +result and argument types must be declared using FFI C types +(@seeCtype). When @scheme[mode] is @scheme[+a] or @scheme[-a], the +method is called in atomic mode (see @scheme[_cprocedure]). If a @scheme[method] is declared with a single @scheme[method-id] and no arguments, then @scheme[method-id] must not end with diff --git a/collects/ffi/objc.ss b/collects/ffi/objc.ss index 0b89fb3eb9..bf6884b2c1 100644 --- a/collects/ffi/objc.ss +++ b/collects/ffi/objc.ss @@ -364,7 +364,7 @@ ;; Given a dealloc extension: #'() ;; Need to add one explicitly: - #'((- _void (dealloc) (void)))))]) + #'((-a _void (dealloc) (void)))))]) (syntax/loc stx (begin (define superclass-id superclass) @@ -454,10 +454,13 @@ (syntax-case #'m () [(kind result-type (id arg ...) body0 body ...) (or (free-identifier=? #'kind #'+) - (free-identifier=? #'kind #'-)) + (free-identifier=? #'kind #'-) + (free-identifier=? #'kind #'+a) + (free-identifier=? #'kind #'-a)) (let ([id #'id] [args (syntax->list #'(arg ...))] - [in-class? (free-identifier=? #'kind #'+)]) + [in-class? (or (free-identifier=? #'kind #'+) + (free-identifier=? #'kind #'+a))]) (when (null? args) (unless (identifier? id) (raise-syntax-error #f @@ -485,7 +488,9 @@ '())] [in-cls (if in-class? #'(object_getClass cls) - #'cls)]) + #'cls)] + [atomic? (or (free-identifier=? #'kind #'+a) + (free-identifier=? #'kind #'-a))]) (syntax/loc stx (let ([rt result-type] [arg-id arg-type] ...) @@ -498,7 +503,7 @@ [super-tell do-super-tell]) body0 body ... dealloc-body ...))) - (_fun _id _id arg-type ... -> rt) + (_fun #:atomic? atomic? _id _id arg-type ... -> rt) (generate-layout rt (list arg-id ...)))))))))] [else (raise-syntax-error #f "bad method form" diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index cdd5afabc5..b0bac7395d 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -334,7 +334,7 @@ this procedure type and called from foreign code, then the PLT Scheme process is put into atomic mode while evaluating the Scheme procedure body. In atomic mode, other Scheme threads do not run, so the Scheme code must not call any function that potentially synchronizes with -other threads, otherwise it may deadlock. In addition, the Scheme code +other threads, or else it may deadlock. In addition, the Scheme code must not perform any potentially blocking operation (such as I/O), it must not raise an uncaught exception, it must not perform any escaping continuation jumps, and its non-tail recursion must be minimal to diff --git a/collects/scribblings/reference/booleans.scrbl b/collects/scribblings/reference/booleans.scrbl index 60d36ac334..33c1738fee 100644 --- a/collects/scribblings/reference/booleans.scrbl +++ b/collects/scribblings/reference/booleans.scrbl @@ -128,7 +128,9 @@ type. The property value must be a list of three procedures: @scheme[equal?] to ensure that data cycles are handled properly and to work with @scheme[equal?/recur] (but beware that an arbitrary function can be provided to - @scheme[equal?/recur]). + @scheme[equal?/recur] for recursive checks, which means that + arguments provided to the predicate might be exposed to + arbitrary code). The @scheme[_equal-proc] is called for a pair of structures only when they are not @scheme[eq?], and only when they both From a5b53c63fc7c6cb7e7e863eea73ba0b4382fb018 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Jan 2009 00:54:48 +0000 Subject: [PATCH 39/49] added a parameter to disable the various caches in redex svn: r13024 --- collects/redex/private/matcher.ss | 3120 +++++++++-------- collects/redex/private/reduction-semantics.ss | 2 +- collects/redex/private/tl-test.ss | 39 + collects/redex/redex.scrbl | 31 +- collects/redex/reduction-semantics.ss | 4 +- 5 files changed, 1627 insertions(+), 1569 deletions(-) diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss index 35514a7cbc..b6abf4dcff 100644 --- a/collects/redex/private/matcher.ss +++ b/collects/redex/private/matcher.ss @@ -15,1512 +15,1515 @@ before the pattern compiler is invoked. scheme/match scheme/contract "underscore-allowed.ss") - - (define-struct compiled-pattern (cp)) - (define count 0) - - ;; lang = (listof nt) - ;; nt = (make-nt sym (listof rhs)) - ;; rhs = (make-rhs single-pattern (listof var-info??)) - ;; single-pattern = sexp - (define-struct nt (name rhs) #:inspector (make-inspector)) - (define-struct rhs (pattern var-info) #:inspector (make-inspector)) - - ;; var = (make-var sym sexp) - ;; patterns are sexps with `var's embedded - ;; in them. It means to match the - ;; embedded sexp and return that binding - - ;; bindings = (make-bindings (listof rib)) - ;; rib = (make-bind sym sexp) - ;; if a rib has a pair, the first element of the pair should be treated as a prefix on the identifer - ;; NOTE: the bindings may contain mismatch-ribs temporarily, but they are all removed - ;; by merge-multiples/remove, a helper function called from match-pattern - (define-values (make-bindings bindings-table bindings?) - (let () - (define-struct bindings (table) #:inspector (make-inspector)) ;; for testing, add inspector - (values (lambda (table) - (unless (and (list? table) - (andmap (λ (x) (or (bind? x) (mismatch-bind? x))) table)) - (error 'make-bindings "expected <(listof (union rib mismatch-rib))>, got ~e" table)) - (make-bindings table)) - bindings-table - bindings?))) - - (define-struct bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector - (define-struct mismatch-bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector +(define-struct compiled-pattern (cp)) - ;; repeat = (make-repeat compiled-pattern (listof rib) (union #f symbol) boolean) - (define-struct repeat (pat empty-bindings suffix mismatch?) #:inspector (make-inspector)) ;; inspector for tests below - - ;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch)) - ;; mtch = (make-mtch bindings sexp[context w/none-inside for the hole] (union none sexp[hole])) - ;; mtch is short for "match" - (define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?) +(define count 0) + +(define caching-enabled? (make-parameter #t)) + +;; lang = (listof nt) +;; nt = (make-nt sym (listof rhs)) +;; rhs = (make-rhs single-pattern (listof var-info??)) +;; single-pattern = sexp +(define-struct nt (name rhs) #:inspector (make-inspector)) +(define-struct rhs (pattern var-info) #:inspector (make-inspector)) + +;; var = (make-var sym sexp) +;; patterns are sexps with `var's embedded +;; in them. It means to match the +;; embedded sexp and return that binding + +;; bindings = (make-bindings (listof rib)) +;; rib = (make-bind sym sexp) +;; if a rib has a pair, the first element of the pair should be treated as a prefix on the identifer +;; NOTE: the bindings may contain mismatch-ribs temporarily, but they are all removed +;; by merge-multiples/remove, a helper function called from match-pattern +(define-values (make-bindings bindings-table bindings?) + (let () + (define-struct bindings (table) #:inspector (make-inspector)) ;; for testing, add inspector + (values (lambda (table) + (unless (and (list? table) + (andmap (λ (x) (or (bind? x) (mismatch-bind? x))) table)) + (error 'make-bindings "expected <(listof (union rib mismatch-rib))>, got ~e" table)) + (make-bindings table)) + bindings-table + bindings?))) + +(define-struct bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector +(define-struct mismatch-bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector + +;; repeat = (make-repeat compiled-pattern (listof rib) (union #f symbol) boolean) +(define-struct repeat (pat empty-bindings suffix mismatch?) #:inspector (make-inspector)) ;; inspector for tests below + +;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch)) +;; mtch = (make-mtch bindings sexp[context w/none-inside for the hole] (union none sexp[hole])) +;; mtch is short for "match" +(define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?) + (let () + (define-struct mtch (bindings context hole) #:inspector (make-inspector)) + (values mtch-bindings + mtch-context + mtch-hole + (lambda (a b c) + (unless (bindings? a) + (error 'make-mtch "expected bindings for first agument, got ~e" a)) + (make-mtch a b c)) + mtch?))) + +;; used to mean no context is available; also used as the "name" for an unnamed (ie, normal) hole +(define none + (let () + (define-struct none ()) + (make-none))) +(define (none? x) (eq? x none)) + +;; compiled-lang : (make-compiled-lang (listof nt) +;; hash[sym -o> compiled-pattern] +;; hash[sym -o> compiled-pattern] +;; hash[sym -o> compiled-pattern] +;; hash[sym -o> boolean]) +;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)] +;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)] +;; pict-builder +;; (listof symbol) +;; (listof (listof symbol))) -- keeps track of `primary' non-terminals +;; hole-info = (union #f none) +;; #f means we're not in a `in-hole' context +;; none means we're looking for a hole + +(define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht + has-hole-ht cache bind-names-cache pict-builder + literals nt-map)) + +;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any +(define (lookup-binding bindings + sym + [fail (lambda () + (error 'lookup-binding "didn't find ~e in ~e" sym bindings))]) + (let loop ([ribs (bindings-table bindings)]) + (cond + [(null? ribs) (fail)] + [else + (let ([rib (car ribs)]) + (if (and (bind? rib) (equal? (bind-name rib) sym)) + (bind-exp rib) + (loop (cdr ribs))))]))) + +;; compile-language : language-pict-info[see pict.ss] (listof nt) (listof (listof sym)) -> compiled-lang +(define (compile-language pict-info lang nt-map) + (let* ([clang-ht (make-hasheq)] + [clang-list-ht (make-hasheq)] + [across-ht (make-hasheq)] + [across-list-ht (make-hasheq)] + [has-hole-ht (build-has-hole-ht lang)] + [cache (make-hash)] + [bind-names-cache (make-hash)] + [literals (extract-literals lang)] + [clang (make-compiled-lang lang #f clang-ht clang-list-ht + across-ht across-list-ht + has-hole-ht + cache bind-names-cache + pict-info + literals + nt-map)] + [non-list-nt-table (build-non-list-nt-label lang)] + [list-nt-table (build-list-nt-label lang)] + [do-compilation + (lambda (ht list-ht lang prefix-cross?) + (for-each + (lambda (nt) + (for-each + (lambda (rhs) + (let-values ([(compiled-pattern has-hole?) + (compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross? #f)]) + (let ([add-to-ht + (lambda (ht) + (hash-set! + ht + (nt-name nt) + (cons compiled-pattern (hash-ref ht (nt-name nt)))))] + [may-be-non-list? (may-be-non-list-pattern? (rhs-pattern rhs) non-list-nt-table)] + [may-be-list? (may-be-list-pattern? (rhs-pattern rhs) list-nt-table)]) + (when may-be-non-list? (add-to-ht ht)) + (when may-be-list? (add-to-ht list-ht)) + (unless (or may-be-non-list? may-be-list?) + (error 'compile-language + "internal error: unable to determine whether pattern matches lists, non-lists, or both: ~s" + (rhs-pattern rhs)))))) + (nt-rhs nt))) + lang))] + [init-ht + (lambda (ht) + (for-each (lambda (nt) (hash-set! ht (nt-name nt) null)) + lang))]) + + (init-ht clang-ht) + (init-ht clang-list-ht) + + (hash-for-each + clang-ht + (lambda (nt rhs) + (when (has-underscore? nt) + (error 'compile-language "cannot use underscore in nonterminal name, ~s" nt)))) + + (let ([compatible-context-language + (build-compatible-context-language clang-ht lang)]) + (for-each (lambda (nt) + (hash-set! across-ht (nt-name nt) null) + (hash-set! across-list-ht (nt-name nt) null)) + compatible-context-language) + (do-compilation clang-ht clang-list-ht lang #t) + (do-compilation across-ht across-list-ht compatible-context-language #f) + (struct-copy compiled-lang clang [cclang compatible-context-language])))) + +;; extract-literals : (listof nt) -> (listof symbol) +(define (extract-literals nts) + (let ([literals-ht (make-hasheq)] + [nt-names (map nt-name nts)]) + (for-each (λ (nt) + (for-each (λ (rhs) (extract-literals/pat nt-names (rhs-pattern rhs) literals-ht)) + (nt-rhs nt))) + nts) + (hash-map literals-ht (λ (x y) x)))) + +;; extract-literals/pat : (listof sym) pattern ht -> void +;; inserts the literals mentioned in pat into ht +(define (extract-literals/pat nts pat ht) + (let loop ([pat pat]) + (match pat + [`any (void)] + [`number (void)] + [`string (void)] + [`variable (void)] + [`(variable-except ,s ...) (void)] + [`(variable-prefix ,s) (void)] + [`variable-not-otherwise-mentioned (void)] + [`hole (void)] + [(? symbol? s) + (unless (regexp-match #rx"_" (symbol->string s)) + (unless (regexp-match #rx"^\\.\\.\\." (symbol->string s)) + (unless (memq s nts) + (hash-set! ht s #t))))] + [`(name ,name ,pat) (loop pat)] + [`(in-hole ,p1 ,p2) + (loop p1) + (loop p2)] + [`(hide-hole ,p) (loop p)] + [`(side-condition ,p ,g) + (loop p)] + [`(cross ,s) (void)] + [_ + (let l-loop ([l-pat pat]) + (when (pair? l-pat) + (loop (car l-pat)) + (l-loop (cdr l-pat))))]))) + +; build-has-hole-ht : (listof nt) -> hash[symbol -o> boolean] +; produces a map of nonterminal -> whether that nonterminal could produce a hole +(define (build-has-hole-ht lang) + (build-nt-property + lang + (lambda (pattern recur) + (match pattern + [`any #f] + [`number #f] + [`string #f] + [`variable #f] + [`(variable-except ,vars ...) #f] + [`(variable-prefix ,var) #f] + [`variable-not-otherwise-mentioned #f] + [`hole #t] + [(? string?) #f] + [(? symbol?) + ;; cannot be a non-terminal, otherwise this function isn't called + #f] + [`(name ,name ,pat) + (recur pat)] + [`(in-hole ,context ,contractum) + (recur contractum)] + [`(hide-hole ,arg) #f] + [`(side-condition ,pat ,condition) + (recur pat)] + [(? list?) + (ormap recur pattern)] + [else #f])) + #t + (lambda (lst) (ormap values lst)))) + +;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean +;; -> hash[symbol[nt] -> boolean] +(define (build-nt-property lang test-rhs conservative-answer combine-rhss) + (let ([ht (make-hasheq)] + [rhs-ht (make-hasheq)]) + (for-each + (lambda (nt) + (hash-set! rhs-ht (nt-name nt) (nt-rhs nt)) + (hash-set! ht (nt-name nt) 'unknown)) + lang) (let () - (define-struct mtch (bindings context hole) #:inspector (make-inspector)) - (values mtch-bindings - mtch-context - mtch-hole - (lambda (a b c) - (unless (bindings? a) - (error 'make-mtch "expected bindings for first agument, got ~e" a)) - (make-mtch a b c)) - mtch?))) + (define (check-nt nt-sym) + (let ([current (hash-ref ht nt-sym)]) + (case current + [(unknown) + (hash-set! ht nt-sym 'computing) + (let ([answer (combine-rhss + (map (lambda (x) (check-rhs (rhs-pattern x))) + (hash-ref rhs-ht nt-sym)))]) + (hash-set! ht nt-sym answer) + answer)] + [(computing) conservative-answer] + [else current]))) + (define (check-rhs rhs) + (cond + [(hash-maps? ht rhs) + (check-nt rhs)] + [else (test-rhs rhs check-rhs)])) + (for-each (lambda (nt) (check-nt (nt-name nt))) + lang) + ht))) + +;; build-compatible-context-language : lang -> lang +(define (build-compatible-context-language clang-ht lang) + (remove-empty-compatible-contexts + (apply + append + (map + (lambda (nt1) + (map + (lambda (nt2) + (let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)]) + (if (eq? (nt-name nt1) (nt-name nt2)) + (make-nt (nt-name compat-nt) + (cons + (make-rhs 'hole '()) + (nt-rhs compat-nt))) + compat-nt))) + lang)) + lang)))) + +;; remove-empty-compatible-contexts : lang -> lang +;; Removes the empty compatible context non-terminals and the +;; rhss that reference them. +(define (remove-empty-compatible-contexts lang) + (define (has-cross? pattern crosses) + (match pattern + [`(cross ,(? symbol? nt)) (memq nt crosses)] + [(list-rest p '... rest) (has-cross? rest crosses)] + [(cons first rest) (or (has-cross? first crosses) + (has-cross? rest crosses))] + [_ #f])) + (define (delete-empty nts) + (for/fold ([deleted null] [kept null]) ([nt nts]) + (if (null? (nt-rhs nt)) + (values (cons nt deleted) kept) + (values deleted (cons nt kept))))) + (define (delete-references deleted-names remaining-nts) + (map (λ (nt) + (make-nt (nt-name nt) + (filter (λ (rhs) (not (has-cross? (rhs-pattern rhs) deleted-names))) + (nt-rhs nt)))) + remaining-nts)) - ;; used to mean no context is available; also used as the "name" for an unnamed (ie, normal) hole - (define none - (let () - (define-struct none ()) - (make-none))) - (define (none? x) (eq? x none)) - - ;; compiled-lang : (make-compiled-lang (listof nt) - ;; hash[sym -o> compiled-pattern] - ;; hash[sym -o> compiled-pattern] - ;; hash[sym -o> compiled-pattern] - ;; hash[sym -o> boolean]) - ;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)] - ;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)] - ;; pict-builder - ;; (listof symbol) - ;; (listof (listof symbol))) -- keeps track of `primary' non-terminals - ;; hole-info = (union #f none) - ;; #f means we're not in a `in-hole' context - ;; none means we're looking for a hole - - (define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht - has-hole-ht cache bind-names-cache pict-builder - literals nt-map)) - - ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any - (define (lookup-binding bindings - sym - [fail (lambda () - (error 'lookup-binding "didn't find ~e in ~e" sym bindings))]) - (let loop ([ribs (bindings-table bindings)]) - (cond - [(null? ribs) (fail)] - [else - (let ([rib (car ribs)]) - (if (and (bind? rib) (equal? (bind-name rib) sym)) - (bind-exp rib) - (loop (cdr ribs))))]))) - - ;; compile-language : language-pict-info[see pict.ss] (listof nt) (listof (listof sym)) -> compiled-lang - (define (compile-language pict-info lang nt-map) - (let* ([clang-ht (make-hasheq)] - [clang-list-ht (make-hasheq)] - [across-ht (make-hasheq)] - [across-list-ht (make-hasheq)] - [has-hole-ht (build-has-hole-ht lang)] - [cache (make-hash)] - [bind-names-cache (make-hash)] - [literals (extract-literals lang)] - [clang (make-compiled-lang lang #f clang-ht clang-list-ht - across-ht across-list-ht - has-hole-ht - cache bind-names-cache - pict-info - literals - nt-map)] - [non-list-nt-table (build-non-list-nt-label lang)] - [list-nt-table (build-list-nt-label lang)] - [do-compilation - (lambda (ht list-ht lang prefix-cross?) - (for-each - (lambda (nt) - (for-each - (lambda (rhs) - (let-values ([(compiled-pattern has-hole?) - (compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross? #f)]) - (let ([add-to-ht - (lambda (ht) - (hash-set! - ht - (nt-name nt) - (cons compiled-pattern (hash-ref ht (nt-name nt)))))] - [may-be-non-list? (may-be-non-list-pattern? (rhs-pattern rhs) non-list-nt-table)] - [may-be-list? (may-be-list-pattern? (rhs-pattern rhs) list-nt-table)]) - (when may-be-non-list? (add-to-ht ht)) - (when may-be-list? (add-to-ht list-ht)) - (unless (or may-be-non-list? may-be-list?) - (error 'compile-language - "internal error: unable to determine whether pattern matches lists, non-lists, or both: ~s" - (rhs-pattern rhs)))))) - (nt-rhs nt))) - lang))] - [init-ht - (lambda (ht) - (for-each (lambda (nt) (hash-set! ht (nt-name nt) null)) - lang))]) - - (init-ht clang-ht) - (init-ht clang-list-ht) - - (hash-for-each - clang-ht - (lambda (nt rhs) - (when (has-underscore? nt) - (error 'compile-language "cannot use underscore in nonterminal name, ~s" nt)))) - - (let ([compatible-context-language - (build-compatible-context-language clang-ht lang)]) - (for-each (lambda (nt) - (hash-set! across-ht (nt-name nt) null) - (hash-set! across-list-ht (nt-name nt) null)) - compatible-context-language) - (do-compilation clang-ht clang-list-ht lang #t) - (do-compilation across-ht across-list-ht compatible-context-language #f) - (struct-copy compiled-lang clang [cclang compatible-context-language])))) - - ;; extract-literals : (listof nt) -> (listof symbol) - (define (extract-literals nts) - (let ([literals-ht (make-hasheq)] - [nt-names (map nt-name nts)]) - (for-each (λ (nt) - (for-each (λ (rhs) (extract-literals/pat nt-names (rhs-pattern rhs) literals-ht)) - (nt-rhs nt))) - nts) - (hash-map literals-ht (λ (x y) x)))) - - ;; extract-literals/pat : (listof sym) pattern ht -> void - ;; inserts the literals mentioned in pat into ht - (define (extract-literals/pat nts pat ht) - (let loop ([pat pat]) - (match pat - [`any (void)] - [`number (void)] - [`string (void)] - [`variable (void)] - [`(variable-except ,s ...) (void)] - [`(variable-prefix ,s) (void)] - [`variable-not-otherwise-mentioned (void)] - [`hole (void)] - [(? symbol? s) - (unless (regexp-match #rx"_" (symbol->string s)) - (unless (regexp-match #rx"^\\.\\.\\." (symbol->string s)) - (unless (memq s nts) - (hash-set! ht s #t))))] - [`(name ,name ,pat) (loop pat)] - [`(in-hole ,p1 ,p2) - (loop p1) - (loop p2)] - [`(hide-hole ,p) (loop p)] - [`(side-condition ,p ,g) - (loop p)] - [`(cross ,s) (void)] - [_ - (let l-loop ([l-pat pat]) - (when (pair? l-pat) - (loop (car l-pat)) - (l-loop (cdr l-pat))))]))) - - ; build-has-hole-ht : (listof nt) -> hash[symbol -o> boolean] - ; produces a map of nonterminal -> whether that nonterminal could produce a hole - (define (build-has-hole-ht lang) - (build-nt-property - lang - (lambda (pattern recur) + (let loop ([nts lang]) + (let-values ([(deleted kept) (delete-empty nts)]) + (if (null? deleted) + kept + (loop (delete-references (map nt-name deleted) kept)))))) + +;; build-compatible-contexts : clang-ht prefix nt -> nt +;; constructs the compatible closure evaluation context from nt. +(define (build-compatible-contexts/nt clang-ht prefix nt) + (make-nt + (symbol-append prefix '- (nt-name nt)) + (apply append + (map + (lambda (rhs) + (let-values ([(maker count) (build-compatible-context-maker clang-ht + (rhs-pattern rhs) + prefix)]) + (let loop ([i count]) + (cond + [(zero? i) null] + [else (let ([nts (build-across-nts (nt-name nt) count (- i 1))]) + (cons (make-rhs (maker (box nts)) '()) + (loop (- i 1))))])))) + (nt-rhs nt))))) + +(define (symbol-append . args) + (string->symbol (apply string-append (map symbol->string args)))) + +;; build-across-nts : symbol number number -> (listof pattern) +(define (build-across-nts nt count i) + (let loop ([j count]) + (cond + [(zero? j) null] + [else + (cons (= i (- j 1)) + (loop (- j 1)))]))) + +;; build-compatible-context-maker : symbol pattern -> (values ((box (listof pattern)) -> pattern) number) +;; when the result function is applied, it takes each element +;; of the of the boxed list and plugs them into the places where +;; the nt corresponding from this rhs appeared in the original pattern. +;; The number result is the number of times that the nt appeared in the pattern. +(define (build-compatible-context-maker clang-ht pattern prefix) + (let ([count 0]) + (values + (let loop ([pattern pattern]) (match pattern - [`any #f] - [`number #f] - [`string #f] - [`variable #f] - [`(variable-except ,vars ...) #f] - [`(variable-prefix ,var) #f] - [`variable-not-otherwise-mentioned #f] - [`hole #t] - [(? string?) #f] - [(? symbol?) - ;; cannot be a non-terminal, otherwise this function isn't called - #f] - [`(name ,name ,pat) - (recur pat)] - [`(in-hole ,context ,contractum) - (recur contractum)] - [`(hide-hole ,arg) #f] - [`(side-condition ,pat ,condition) - (recur pat)] - [(? list?) - (ormap recur pattern)] - [else #f])) - #t - (lambda (lst) (ormap values lst)))) - - ;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean - ;; -> hash[symbol[nt] -> boolean] - (define (build-nt-property lang test-rhs conservative-answer combine-rhss) - (let ([ht (make-hasheq)] - [rhs-ht (make-hasheq)]) - (for-each - (lambda (nt) - (hash-set! rhs-ht (nt-name nt) (nt-rhs nt)) - (hash-set! ht (nt-name nt) 'unknown)) - lang) - (let () - (define (check-nt nt-sym) - (let ([current (hash-ref ht nt-sym)]) - (case current - [(unknown) - (hash-set! ht nt-sym 'computing) - (let ([answer (combine-rhss - (map (lambda (x) (check-rhs (rhs-pattern x))) - (hash-ref rhs-ht nt-sym)))]) - (hash-set! ht nt-sym answer) - answer)] - [(computing) conservative-answer] - [else current]))) - (define (check-rhs rhs) + [`any (lambda (l) 'any)] + [`number (lambda (l) 'number)] + [`string (lambda (l) 'string)] + [`variable (lambda (l) 'variable)] + [`(variable-except ,vars ...) (lambda (l) pattern)] + [`(variable-prefix ,var) (lambda (l) pattern)] + [`variable-not-otherwise-mentioned (λ (l) pattern)] + [`hole (lambda (l) 'hole)] + [(? string?) (lambda (l) pattern)] + [(? symbol?) (cond - [(hash-maps? ht rhs) - (check-nt rhs)] - [else (test-rhs rhs check-rhs)])) - (for-each (lambda (nt) (check-nt (nt-name nt))) - lang) - ht))) - - ;; build-compatible-context-language : lang -> lang - (define (build-compatible-context-language clang-ht lang) - (remove-empty-compatible-contexts - (apply - append - (map - (lambda (nt1) - (map - (lambda (nt2) - (let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)]) - (if (eq? (nt-name nt1) (nt-name nt2)) - (make-nt (nt-name compat-nt) - (cons - (make-rhs 'hole '()) - (nt-rhs compat-nt))) - compat-nt))) - lang)) - lang)))) - - ;; remove-empty-compatible-contexts : lang -> lang - ;; Removes the empty compatible context non-terminals and the - ;; rhss that reference them. - (define (remove-empty-compatible-contexts lang) - (define (has-cross? pattern crosses) - (match pattern - [`(cross ,(? symbol? nt)) (memq nt crosses)] - [(list-rest p '... rest) (has-cross? rest crosses)] - [(cons first rest) (or (has-cross? first crosses) - (has-cross? rest crosses))] - [_ #f])) - (define (delete-empty nts) - (for/fold ([deleted null] [kept null]) ([nt nts]) - (if (null? (nt-rhs nt)) - (values (cons nt deleted) kept) - (values deleted (cons nt kept))))) - (define (delete-references deleted-names remaining-nts) - (map (λ (nt) - (make-nt (nt-name nt) - (filter (λ (rhs) (not (has-cross? (rhs-pattern rhs) deleted-names))) - (nt-rhs nt)))) - remaining-nts)) - - (let loop ([nts lang]) - (let-values ([(deleted kept) (delete-empty nts)]) - (if (null? deleted) - kept - (loop (delete-references (map nt-name deleted) kept)))))) - - ;; build-compatible-contexts : clang-ht prefix nt -> nt - ;; constructs the compatible closure evaluation context from nt. - (define (build-compatible-contexts/nt clang-ht prefix nt) - (make-nt - (symbol-append prefix '- (nt-name nt)) - (apply append - (map - (lambda (rhs) - (let-values ([(maker count) (build-compatible-context-maker clang-ht - (rhs-pattern rhs) - prefix)]) - (let loop ([i count]) + [(hash-ref clang-ht pattern #f) + (set! count (+ count 1)) + (lambda (l) + (let ([fst (car (unbox l))]) + (set-box! l (cdr (unbox l))) + (if fst + `(cross ,(symbol-append prefix '- pattern)) + pattern)))] + [else + (lambda (l) pattern)])] + [`(name ,name ,pat) + (let ([patf (loop pat)]) + (lambda (l) + `(name ,name ,(patf l))))] + [`(in-hole ,context ,contractum) + (let ([match-context (loop context)] + [match-contractum (loop contractum)]) + (lambda (l) + `(in-hole ,(match-context l) + ,(match-contractum l))))] + [`(hide-hole ,p) + (let ([m (loop p)]) + (lambda (l) + `(hide-hole ,(m l))))] + [`(side-condition ,pat ,condition) + (let ([patf (loop pat)]) + (lambda (l) + `(side-condition ,(patf l) ,condition)))] + [(? list?) + (let ([f/pats + (let l-loop ([pattern pattern]) (cond - [(zero? i) null] - [else (let ([nts (build-across-nts (nt-name nt) count (- i 1))]) - (cons (make-rhs (maker (box nts)) '()) - (loop (- i 1))))])))) - (nt-rhs nt))))) - - (define (symbol-append . args) - (string->symbol (apply string-append (map symbol->string args)))) - - ;; build-across-nts : symbol number number -> (listof pattern) - (define (build-across-nts nt count i) - (let loop ([j count]) - (cond - [(zero? j) null] - [else - (cons (= i (- j 1)) - (loop (- j 1)))]))) - - ;; build-compatible-context-maker : symbol pattern -> (values ((box (listof pattern)) -> pattern) number) - ;; when the result function is applied, it takes each element - ;; of the of the boxed list and plugs them into the places where - ;; the nt corresponding from this rhs appeared in the original pattern. - ;; The number result is the number of times that the nt appeared in the pattern. - (define (build-compatible-context-maker clang-ht pattern prefix) - (let ([count 0]) - (values - (let loop ([pattern pattern]) - (match pattern - [`any (lambda (l) 'any)] - [`number (lambda (l) 'number)] - [`string (lambda (l) 'string)] - [`variable (lambda (l) 'variable)] - [`(variable-except ,vars ...) (lambda (l) pattern)] - [`(variable-prefix ,var) (lambda (l) pattern)] - [`variable-not-otherwise-mentioned (λ (l) pattern)] - [`hole (lambda (l) 'hole)] - [(? string?) (lambda (l) pattern)] - [(? symbol?) - (cond - [(hash-ref clang-ht pattern #f) - (set! count (+ count 1)) - (lambda (l) - (let ([fst (car (unbox l))]) - (set-box! l (cdr (unbox l))) - (if fst - `(cross ,(symbol-append prefix '- pattern)) - pattern)))] - [else - (lambda (l) pattern)])] - [`(name ,name ,pat) - (let ([patf (loop pat)]) - (lambda (l) - `(name ,name ,(patf l))))] - [`(in-hole ,context ,contractum) - (let ([match-context (loop context)] - [match-contractum (loop contractum)]) - (lambda (l) - `(in-hole ,(match-context l) - ,(match-contractum l))))] - [`(hide-hole ,p) - (let ([m (loop p)]) - (lambda (l) - `(hide-hole ,(m l))))] - [`(side-condition ,pat ,condition) - (let ([patf (loop pat)]) - (lambda (l) - `(side-condition ,(patf l) ,condition)))] - [(? list?) - (let ([f/pats - (let l-loop ([pattern pattern]) + [(null? pattern) null] + [(null? (cdr pattern)) + (list (vector (loop (car pattern)) + #f + #f))] + [(eq? (cadr pattern) '...) + (cons (vector (loop (car pattern)) + #t + (car pattern)) + (l-loop (cddr pattern)))] + [else + (cons (vector (loop (car pattern)) + #f + #f) + (l-loop (cdr pattern)))]))]) + (lambda (l) + (let loop ([f/pats f/pats]) + (cond + [(null? f/pats) null] + [else + (let ([f/pat (car f/pats)]) (cond - [(null? pattern) null] - [(null? (cdr pattern)) - (list (vector (loop (car pattern)) - #f - #f))] - [(eq? (cadr pattern) '...) - (cons (vector (loop (car pattern)) - #t - (car pattern)) - (l-loop (cddr pattern)))] + [(vector-ref f/pat 1) + (let ([new ((vector-ref f/pat 0) l)] + [pat (vector-ref f/pat 2)]) + (if (equal? new pat) + (list* pat + '... + (loop (cdr f/pats))) + (list* (vector-ref f/pat 2) + '... + new + (vector-ref f/pat 2) + '... + (loop (cdr f/pats)))))] [else - (cons (vector (loop (car pattern)) - #f - #f) - (l-loop (cdr pattern)))]))]) - (lambda (l) - (let loop ([f/pats f/pats]) - (cond - [(null? f/pats) null] - [else - (let ([f/pat (car f/pats)]) - (cond - [(vector-ref f/pat 1) - (let ([new ((vector-ref f/pat 0) l)] - [pat (vector-ref f/pat 2)]) - (if (equal? new pat) - (list* pat - '... - (loop (cdr f/pats))) - (list* (vector-ref f/pat 2) - '... - new - (vector-ref f/pat 2) - '... - (loop (cdr f/pats)))))] - [else - (cons ((vector-ref f/pat 0) l) - (loop (cdr f/pats)))]))]))))] - [else - (lambda (l) pattern)])) - count))) - - ;; build-list-nt-label : lang -> hash[symbol -o> boolean] - (define (build-list-nt-label lang) - (build-nt-property - lang - (lambda (pattern recur) - (may-be-list-pattern?/internal pattern - (lambda (sym) #f) - recur)) - #t - (lambda (lst) (ormap values lst)))) - - (define (may-be-list-pattern? pattern list-nt-table) - (let loop ([pattern pattern]) - (may-be-list-pattern?/internal - pattern - (lambda (sym) - (hash-ref list-nt-table (symbol->nt sym) #t)) - loop))) - - (define (may-be-list-pattern?/internal pattern handle-symbol recur) - (match pattern - [`any #t] - [`number #f] - [`string #f] - [`variable #f] - [`(variable-except ,vars ...) #f] - [`variable-not-otherwise-mentioned #f] - [`(variable-prefix ,var) #f] - [`hole #t] - [(? string?) #f] - [(? symbol?) - (handle-symbol pattern)] - [`(name ,name ,pat) - (recur pat)] - [`(in-hole ,context ,contractum) - (recur context)] - [`(hide-hole ,p) - (recur p)] - [`(side-condition ,pat ,condition) - (recur pat)] - [(? list?) - #t] - [else - ;; is this right?! - (or (null? pattern) (pair? pattern))])) + (cons ((vector-ref f/pat 0) l) + (loop (cdr f/pats)))]))]))))] + [else + (lambda (l) pattern)])) + count))) +;; build-list-nt-label : lang -> hash[symbol -o> boolean] +(define (build-list-nt-label lang) + (build-nt-property + lang + (lambda (pattern recur) + (may-be-list-pattern?/internal pattern + (lambda (sym) #f) + recur)) + #t + (lambda (lst) (ormap values lst)))) + +(define (may-be-list-pattern? pattern list-nt-table) + (let loop ([pattern pattern]) + (may-be-list-pattern?/internal + pattern + (lambda (sym) + (hash-ref list-nt-table (symbol->nt sym) #t)) + loop))) + +(define (may-be-list-pattern?/internal pattern handle-symbol recur) + (match pattern + [`any #t] + [`number #f] + [`string #f] + [`variable #f] + [`(variable-except ,vars ...) #f] + [`variable-not-otherwise-mentioned #f] + [`(variable-prefix ,var) #f] + [`hole #t] + [(? string?) #f] + [(? symbol?) + (handle-symbol pattern)] + [`(name ,name ,pat) + (recur pat)] + [`(in-hole ,context ,contractum) + (recur context)] + [`(hide-hole ,p) + (recur p)] + [`(side-condition ,pat ,condition) + (recur pat)] + [(? list?) + #t] + [else + ;; is this right?! + (or (null? pattern) (pair? pattern))])) + + +;; build-non-list-nt-label : lang -> hash[symbol -o> boolean] +(define (build-non-list-nt-label lang) + (build-nt-property + lang + (lambda (pattern recur) + (may-be-non-list-pattern?/internal pattern + (lambda (sym) #t) + recur)) + #t + (lambda (lst) (ormap values lst)))) + +(define (may-be-non-list-pattern? pattern non-list-nt-table) + (let loop ([pattern pattern]) + (may-be-non-list-pattern?/internal + pattern + (lambda (sym) + (hash-ref non-list-nt-table (symbol->nt sym) #t)) + loop))) + +(define (may-be-non-list-pattern?/internal pattern handle-sym recur) + (match pattern + [`any #t] + [`number #t] + [`string #t] + [`variable #t] + [`(variable-except ,vars ...) #t] + [`variable-not-otherwise-mentioned #t] + [`(variable-prefix ,prefix) #t] + [`hole #t] + [(? string?) #t] + [(? symbol?) (handle-sym pattern)] + [`(name ,name ,pat) + (recur pat)] + [`(in-hole ,context ,contractum) + (recur context)] + [`(hide-hole ,p) + (recur p)] + [`(side-condition ,pat ,condition) + (recur pat)] + [(? list?) + #f] + [else + ;; is this right?! + (not (or (null? pattern) (pair? pattern)))])) + +;; match-pattern : compiled-pattern exp -> (union #f (listof bindings)) +(define (match-pattern compiled-pattern exp) + (let ([results ((compiled-pattern-cp compiled-pattern) exp #f)]) + (and results + (let ([filtered (filter-multiples results)]) + (and (not (null? filtered)) + filtered))))) + +;; filter-multiples : (listof mtch) -> (listof mtch) +(define (filter-multiples matches) + (let loop ([matches matches] + [acc null]) + (cond + [(null? matches) acc] + [else + (let ([merged (merge-multiples/remove (car matches))]) + (if merged + (loop (cdr matches) (cons merged acc)) + (loop (cdr matches) acc)))]))) + +;; merge-multiples/remove : bindings -> (union #f bindings) +;; returns #f if all duplicate bindings don't bind the same thing +;; returns a new bindings +(define (merge-multiples/remove match) + (let/ec fail + (let ( + ;; match-ht : sym -o> sexp + [match-ht (make-hash)] + + ;; mismatch-ht : sym -o> hash[sexp -o> #t] + [mismatch-ht (make-hash)] + + [ribs (bindings-table (mtch-bindings match))]) + (for-each + (lambda (rib) + (cond + [(bind? rib) + (let ([name (bind-name rib)] + [exp (bind-exp rib)]) + (let ([previous-exp (hash-ref match-ht name uniq)]) + (cond + [(eq? previous-exp uniq) + (hash-set! match-ht name exp)] + [else + (unless (equal? exp previous-exp) + (fail #f))])))] + [(mismatch-bind? rib) + (let* ([name (mismatch-bind-name rib)] + [exp (mismatch-bind-exp rib)] + [priors (hash-ref mismatch-ht name uniq)]) + (when (eq? priors uniq) + (let ([table (make-hash)]) + (hash-set! mismatch-ht name table) + (set! priors table))) + (when (hash-ref priors exp #f) + (fail #f)) + (hash-set! priors exp #t))])) + ribs) + (make-mtch + (make-bindings (hash-map match-ht make-bind)) + (mtch-context match) + (mtch-hole match))))) + +;; compile-pattern : compiled-lang pattern boolean (listof sym) -> compiled-pattern +(define (compile-pattern clang pattern bind-names?) + (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t bind-names?)]) + (make-compiled-pattern pattern))) + +;; name-to-key/binding : hash[symbol -o> key-wrap] +(define name-to-key/binding (make-hasheq)) +(define-struct key-wrap (sym) #:inspector (make-inspector)) + +;; compile-pattern/cross? : compiled-lang pattern boolean boolean -> (values compiled-pattern boolean) +(define (compile-pattern/cross? clang pattern prefix-cross? bind-names?) + (define clang-ht (compiled-lang-ht clang)) + (define clang-list-ht (compiled-lang-list-ht clang)) + (define has-hole-ht (compiled-lang-has-hole-ht clang)) + (define across-ht (compiled-lang-across-ht clang)) + (define across-list-ht (compiled-lang-across-list-ht clang)) - ;; build-non-list-nt-label : lang -> hash[symbol -o> boolean] - (define (build-non-list-nt-label lang) - (build-nt-property - lang - (lambda (pattern recur) - (may-be-non-list-pattern?/internal pattern - (lambda (sym) #t) - recur)) - #t - (lambda (lst) (ormap values lst)))) + (define (compile-pattern/default-cache pattern) + (compile-pattern/cache pattern + (if bind-names? + (compiled-lang-bind-names-cache clang) + (compiled-lang-cache clang)))) - (define (may-be-non-list-pattern? pattern non-list-nt-table) - (let loop ([pattern pattern]) - (may-be-non-list-pattern?/internal - pattern - (lambda (sym) - (hash-ref non-list-nt-table (symbol->nt sym) #t)) - loop))) - - (define (may-be-non-list-pattern?/internal pattern handle-sym recur) - (match pattern - [`any #t] - [`number #t] - [`string #t] - [`variable #t] - [`(variable-except ,vars ...) #t] - [`variable-not-otherwise-mentioned #t] - [`(variable-prefix ,prefix) #t] - [`hole #t] - [(? string?) #t] - [(? symbol?) (handle-sym pattern)] - [`(name ,name ,pat) - (recur pat)] - [`(in-hole ,context ,contractum) - (recur context)] - [`(hide-hole ,p) - (recur p)] - [`(side-condition ,pat ,condition) - (recur pat)] - [(? list?) - #f] - [else - ;; is this right?! - (not (or (null? pattern) (pair? pattern)))])) - - ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings)) - (define (match-pattern compiled-pattern exp) - (let ([results ((compiled-pattern-cp compiled-pattern) exp #f)]) - (and results - (let ([filtered (filter-multiples results)]) - (and (not (null? filtered)) - filtered))))) - - ;; filter-multiples : (listof mtch) -> (listof mtch) - (define (filter-multiples matches) - (let loop ([matches matches] - [acc null]) - (cond - [(null? matches) acc] + (define (compile-pattern/cache pattern compiled-pattern-cache) + (let ([compiled-cache (hash-ref compiled-pattern-cache pattern uniq)]) + (cond + [(eq? compiled-cache uniq) + (let-values ([(compiled-pattern has-hole?) + (true-compile-pattern pattern)]) + (let ([val (list (memoize compiled-pattern has-hole?) has-hole?)]) + (hash-set! compiled-pattern-cache pattern val) + (apply values val)))] [else - (let ([merged (merge-multiples/remove (car matches))]) - (if merged - (loop (cdr matches) (cons merged acc)) - (loop (cdr matches) acc)))]))) + (apply values compiled-cache)]))) - ;; merge-multiples/remove : bindings -> (union #f bindings) - ;; returns #f if all duplicate bindings don't bind the same thing - ;; returns a new bindings - (define (merge-multiples/remove match) - (let/ec fail - (let ( - ;; match-ht : sym -o> sexp - [match-ht (make-hash)] - - ;; mismatch-ht : sym -o> hash[sexp -o> #t] - [mismatch-ht (make-hash)] - - [ribs (bindings-table (mtch-bindings match))]) - (for-each - (lambda (rib) - (cond - [(bind? rib) - (let ([name (bind-name rib)] - [exp (bind-exp rib)]) - (let ([previous-exp (hash-ref match-ht name uniq)]) - (cond - [(eq? previous-exp uniq) - (hash-set! match-ht name exp)] - [else - (unless (equal? exp previous-exp) - (fail #f))])))] - [(mismatch-bind? rib) - (let* ([name (mismatch-bind-name rib)] - [exp (mismatch-bind-exp rib)] - [priors (hash-ref mismatch-ht name uniq)]) - (when (eq? priors uniq) - (let ([table (make-hash)]) - (hash-set! mismatch-ht name table) - (set! priors table))) - (when (hash-ref priors exp #f) - (fail #f)) - (hash-set! priors exp #t))])) - ribs) - (make-mtch - (make-bindings (hash-map match-ht make-bind)) - (mtch-context match) - (mtch-hole match))))) - - ;; compile-pattern : compiled-lang pattern boolean (listof sym) -> compiled-pattern - (define (compile-pattern clang pattern bind-names?) - (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t bind-names?)]) - (make-compiled-pattern pattern))) - - ;; name-to-key/binding : hash[symbol -o> key-wrap] - (define name-to-key/binding (make-hasheq)) - (define-struct key-wrap (sym) #:inspector (make-inspector)) - - ;; compile-pattern/cross? : compiled-lang pattern boolean boolean -> (values compiled-pattern boolean) - (define (compile-pattern/cross? clang pattern prefix-cross? bind-names?) - (define clang-ht (compiled-lang-ht clang)) - (define clang-list-ht (compiled-lang-list-ht clang)) - (define has-hole-ht (compiled-lang-has-hole-ht clang)) - (define across-ht (compiled-lang-across-ht clang)) - (define across-list-ht (compiled-lang-across-list-ht clang)) - - (define (compile-pattern/default-cache pattern) - (compile-pattern/cache pattern - (if bind-names? - (compiled-lang-bind-names-cache clang) - (compiled-lang-cache clang)))) - - (define (compile-pattern/cache pattern compiled-pattern-cache) - (let ([compiled-cache (hash-ref compiled-pattern-cache pattern uniq)]) - (cond - [(eq? compiled-cache uniq) - (let-values ([(compiled-pattern has-hole?) - (true-compile-pattern pattern)]) - (let ([val (list (memoize compiled-pattern has-hole?) has-hole?)]) - (hash-set! compiled-pattern-cache pattern val) - (apply values val)))] - [else - (apply values compiled-cache)]))) - - (define (true-compile-pattern pattern) - (match pattern - [(? (lambda (x) (eq? x '....))) - (error 'compile-language "the pattern .... can only be used in extend-language")] - [`(variable-except ,vars ...) - (values - (lambda (exp hole-info) - (and (symbol? exp) - (not (memq exp vars)) - (list (make-mtch (make-bindings null) - (build-flat-context exp) - none)))) - #f)] - [`(variable-prefix ,var) - (values - (let* ([prefix-str (symbol->string var)] - [prefix-len (string-length prefix-str)]) - (lambda (exp hole-info) - (and (symbol? exp) - (let ([str (symbol->string exp)]) - (and ((string-length str) . >= . prefix-len) - (string=? (substring str 0 prefix-len) prefix-str) - (list (make-mtch (make-bindings null) - (build-flat-context exp) - none))))))) - #f)] - [`variable-not-otherwise-mentioned - (values - (let ([literals (compiled-lang-literals clang)]) - (lambda (exp hole-info) - (and (symbol? exp) - (not (memq exp literals)) - (list (make-mtch (make-bindings null) - (build-flat-context exp) - none))))) - #f)] - [`hole - (values (match-hole none) #t)] - [(? string?) - (values + (define (true-compile-pattern pattern) + (match pattern + [(? (lambda (x) (eq? x '....))) + (error 'compile-language "the pattern .... can only be used in extend-language")] + [`(variable-except ,vars ...) + (values + (lambda (exp hole-info) + (and (symbol? exp) + (not (memq exp vars)) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)] + [`(variable-prefix ,var) + (values + (let* ([prefix-str (symbol->string var)] + [prefix-len (string-length prefix-str)]) (lambda (exp hole-info) - (and (string? exp) - (string=? exp pattern) + (and (symbol? exp) + (let ([str (symbol->string exp)]) + (and ((string-length str) . >= . prefix-len) + (string=? (substring str 0 prefix-len) prefix-str) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none))))))) + #f)] + [`variable-not-otherwise-mentioned + (values + (let ([literals (compiled-lang-literals clang)]) + (lambda (exp hole-info) + (and (symbol? exp) + (not (memq exp literals)) (list (make-mtch (make-bindings null) (build-flat-context exp) - none)))) - #f)] - [(? symbol?) - (cond - [(has-underscore? pattern) - (let*-values ([(binder before-underscore) - (let ([before (split-underscore pattern)]) - (unless (or (hash-maps? clang-ht before) - (memq before underscore-allowed)) - (error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s" - before - (format "~s" (list* 'one 'of: (hash-map clang-ht (λ (x y) x)))) - pattern)) - (values pattern before))] - [(match-raw-name has-hole?) - (compile-id-pattern before-underscore)]) - (values - (match-named-pat binder match-raw-name) - has-hole?))] - [else - (let-values ([(match-raw-name has-hole?) (compile-id-pattern pattern)]) - (values (if (non-underscore-binder? pattern) - (match-named-pat pattern match-raw-name) - match-raw-name) - has-hole?))])] - [`(cross ,(? symbol? pre-id)) - (let ([id (if prefix-cross? - (symbol-append pre-id '- pre-id) - pre-id)]) - (cond - [(hash-maps? across-ht id) - (values - (lambda (exp hole-info) - (match-nt (hash-ref across-list-ht id) - (hash-ref across-ht id) - id exp hole-info)) - #t)] - [else - (error 'compile-pattern "unknown cross reference ~a" id)]))] - - [`(name ,name ,pat) - (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) - (values (match-named-pat name match-pat) - has-hole?))] - [`(in-hole ,context ,contractum) - (let-values ([(match-context ctxt-has-hole?) (compile-pattern/default-cache context)] - [(match-contractum contractum-has-hole?) (compile-pattern/default-cache contractum)]) + none))))) + #f)] + [`hole + (values (match-hole none) #t)] + [(? string?) + (values + (lambda (exp hole-info) + (and (string? exp) + (string=? exp pattern) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)] + [(? symbol?) + (cond + [(has-underscore? pattern) + (let*-values ([(binder before-underscore) + (let ([before (split-underscore pattern)]) + (unless (or (hash-maps? clang-ht before) + (memq before underscore-allowed)) + (error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s" + before + (format "~s" (list* 'one 'of: (hash-map clang-ht (λ (x y) x)))) + pattern)) + (values pattern before))] + [(match-raw-name has-hole?) + (compile-id-pattern before-underscore)]) (values - (match-in-hole context contractum exp match-context match-contractum none) - (or ctxt-has-hole? contractum-has-hole?)))] - [`(hide-hole ,p) - (let-values ([(match-pat has-hole?) (compile-pattern/default-cache p)]) + (match-named-pat binder match-raw-name) + has-hole?))] + [else + (let-values ([(match-raw-name has-hole?) (compile-id-pattern pattern)]) + (values (if (non-underscore-binder? pattern) + (match-named-pat pattern match-raw-name) + match-raw-name) + has-hole?))])] + [`(cross ,(? symbol? pre-id)) + (let ([id (if prefix-cross? + (symbol-append pre-id '- pre-id) + pre-id)]) + (cond + [(hash-maps? across-ht id) + (values + (lambda (exp hole-info) + (match-nt (hash-ref across-list-ht id) + (hash-ref across-ht id) + id exp hole-info)) + #t)] + [else + (error 'compile-pattern "unknown cross reference ~a" id)]))] + + [`(name ,name ,pat) + (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) + (values (match-named-pat name match-pat) + has-hole?))] + [`(in-hole ,context ,contractum) + (let-values ([(match-context ctxt-has-hole?) (compile-pattern/default-cache context)] + [(match-contractum contractum-has-hole?) (compile-pattern/default-cache contractum)]) + (values + (match-in-hole context contractum exp match-context match-contractum none) + (or ctxt-has-hole? contractum-has-hole?)))] + [`(hide-hole ,p) + (let-values ([(match-pat has-hole?) (compile-pattern/default-cache p)]) + (values + (lambda (exp hole-info) + (let ([matches (match-pat exp #f)]) + (and matches + (map (λ (match) (make-mtch (mtch-bindings match) (mtch-context match) none)) + matches)))) + #f))] + + [`(side-condition ,pat ,condition) + (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) + (values + (lambda (exp hole-info) + (let ([matches (match-pat exp hole-info)]) + (and matches + (let ([filtered (filter (λ (m) (condition (mtch-bindings m))) matches)]) + (if (null? filtered) + #f + filtered))))) + has-hole?))] + [(? (lambda (x) (list? x))) ;; this eta expansion is to defeat a bug in match + (let-values ([(rewritten has-hole?) (rewrite-ellipses non-underscore-binder? pattern compile-pattern/default-cache)]) + (let ([count (and (not (ormap repeat? rewritten)) + (length rewritten))]) (values (lambda (exp hole-info) - (let ([matches (match-pat exp #f)]) - (and matches - (map (λ (match) (make-mtch (mtch-bindings match) (mtch-context match) none)) - matches)))) - #f))] - - [`(side-condition ,pat ,condition) - (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) - (values - (lambda (exp hole-info) - (let ([matches (match-pat exp hole-info)]) - (and matches - (let ([filtered (filter (λ (m) (condition (mtch-bindings m))) matches)]) - (if (null? filtered) - #f - filtered))))) - has-hole?))] - [(? (lambda (x) (list? x))) ;; this eta expansion is to defeat a bug in match - (let-values ([(rewritten has-hole?) (rewrite-ellipses non-underscore-binder? pattern compile-pattern/default-cache)]) - (let ([count (and (not (ormap repeat? rewritten)) - (length rewritten))]) - (values - (lambda (exp hole-info) - (cond - [(list? exp) - ;; shortcircuit: if the list isn't the right length, give up immediately. - (if (and count - (not (= (length exp) count))) - #f - (match-list rewritten exp hole-info))] - [else #f])) - has-hole?)))] - - ;; an already comiled pattern - [(? compiled-pattern?) - ;; return #t here as a failsafe; no way to check better. - (values (compiled-pattern-cp pattern) - #t)] - - [else - (values - (lambda (exp hole-info) - (and (eqv? pattern exp) - (list (make-mtch (make-bindings null) - (build-flat-context exp) - none)))) - #f)])) - - (define (non-underscore-binder? pattern) - (and bind-names? - (or (hash-maps? clang-ht pattern) - (memq pattern underscore-allowed)))) - - ;; compile-id-pattern : symbol[with-out-underscore] -> (values boolean) - (define (compile-id-pattern pat) - (match pat - [`any (simple-match 'any (λ (x) #t))] - [`number (simple-match 'number number?)] - [`string (simple-match 'string string?)] - [`variable (simple-match 'variable symbol?)] - [(? is-non-terminal?) - (values - (lambda (exp hole-info) - (match-nt (hash-ref clang-list-ht pat) - (hash-ref clang-ht pat) - pat exp hole-info)) - (hash-ref has-hole-ht pat))] - [else - (values - (lambda (exp hole-info) - (and (eq? exp pat) - (list (make-mtch (make-bindings null) - (build-flat-context exp) - none)))) - #f)])) - - (define (is-non-terminal? sym) (hash-maps? clang-ht sym)) + (cond + [(list? exp) + ;; shortcircuit: if the list isn't the right length, give up immediately. + (if (and count + (not (= (length exp) count))) + #f + (match-list rewritten exp hole-info))] + [else #f])) + has-hole?)))] + + ;; an already comiled pattern + [(? compiled-pattern?) + ;; return #t here as a failsafe; no way to check better. + (values (compiled-pattern-cp pattern) + #t)] + + [else + (values + (lambda (exp hole-info) + (and (eqv? pattern exp) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)])) + + (define (non-underscore-binder? pattern) + (and bind-names? + (or (hash-maps? clang-ht pattern) + (memq pattern underscore-allowed)))) + + ;; compile-id-pattern : symbol[with-out-underscore] -> (values boolean) + (define (compile-id-pattern pat) + (match pat + [`any (simple-match 'any (λ (x) #t))] + [`number (simple-match 'number number?)] + [`string (simple-match 'string string?)] + [`variable (simple-match 'variable symbol?)] + [(? is-non-terminal?) + (values + (lambda (exp hole-info) + (match-nt (hash-ref clang-list-ht pat) + (hash-ref clang-ht pat) + pat exp hole-info)) + (hash-ref has-hole-ht pat))] + [else + (values + (lambda (exp hole-info) + (and (eq? exp pat) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)])) + + (define (is-non-terminal? sym) (hash-maps? clang-ht sym)) + + ;; simple-match : sym (any -> bool) -> (values boolean) + ;; does a match based on a built-in Scheme predicate + (define (simple-match binder pred) + (values (lambda (exp hole-info) + (and (pred exp) + (list (make-mtch + (make-bindings null) + (build-flat-context exp) + none)))) + #f)) + + (compile-pattern/default-cache pattern)) - ;; simple-match : sym (any -> bool) -> (values boolean) - ;; does a match based on a built-in Scheme predicate - (define (simple-match binder pred) - (values (lambda (exp hole-info) - (and (pred exp) - (list (make-mtch - (make-bindings null) - (build-flat-context exp) - none)))) - #f)) - - (compile-pattern/default-cache pattern)) - - ;; match-named-pat : symbol -> - (define (match-named-pat name match-pat) - (let ([mismatch-bind? (regexp-match #rx"_!_" (symbol->string name))]) - (lambda (exp hole-info) - (let ([matches (match-pat exp hole-info)]) - (and matches - (map (lambda (match) - (make-mtch - (make-bindings (cons (if mismatch-bind? - (make-mismatch-bind name (mtch-context match)) - (make-bind name (mtch-context match))) - (bindings-table (mtch-bindings match)))) - (mtch-context match) - (mtch-hole match))) - matches)))))) - - ;; split-underscore : symbol -> symbol - ;; returns the text before the underscore in a symbol (as a symbol) - ;; raise an error if there is more than one underscore in the input - (define (split-underscore sym) - (let ([str (symbol->string sym)]) - (cond - [(regexp-match #rx"^([^_]*)_[^_]*$" str) - => - (λ (m) (string->symbol (cadr m)))] - [(regexp-match #rx"^([^_]*)_!_[^_]*$" str) - => - (λ (m) (string->symbol (cadr m)))] - [else - (error 'compile-pattern "found a symbol with multiple underscores: ~s" sym)]))) - - ;; has-underscore? : symbol -> boolean - (define (has-underscore? sym) - (memq #\_ (string->list (symbol->string sym)))) - - ;; symbol->nt : symbol -> symbol - ;; strips the trailing underscore from a symbol, if one is there. - (define (symbol->nt sym) +;; match-named-pat : symbol -> +(define (match-named-pat name match-pat) + (let ([mismatch-bind? (regexp-match #rx"_!_" (symbol->string name))]) + (lambda (exp hole-info) + (let ([matches (match-pat exp hole-info)]) + (and matches + (map (lambda (match) + (make-mtch + (make-bindings (cons (if mismatch-bind? + (make-mismatch-bind name (mtch-context match)) + (make-bind name (mtch-context match))) + (bindings-table (mtch-bindings match)))) + (mtch-context match) + (mtch-hole match))) + matches)))))) + +;; split-underscore : symbol -> symbol +;; returns the text before the underscore in a symbol (as a symbol) +;; raise an error if there is more than one underscore in the input +(define (split-underscore sym) + (let ([str (symbol->string sym)]) (cond - [(has-underscore? sym) - (split-underscore sym)] - [else sym])) - - (define (memoize f needs-all-args?) - (if needs-all-args? - (memoize2 f) - (memoize1 f))) - - ; memoize1 : (x y -> w) -> x y -> w - ; memoizes a function of two arguments under the assumption - ; that the function is constant w.r.t the second - (define (memoize1 f) (memoize/key f (lambda (x y) x) nohole)) - (define (memoize2 f) (memoize/key f cons w/hole)) + [(regexp-match #rx"^([^_]*)_[^_]*$" str) + => + (λ (m) (string->symbol (cadr m)))] + [(regexp-match #rx"^([^_]*)_!_[^_]*$" str) + => + (λ (m) (string->symbol (cadr m)))] + [else + (error 'compile-pattern "found a symbol with multiple underscores: ~s" sym)]))) - (define cache-size 350) - (define (set-cache-size! cs) (set! cache-size cs)) - - ;; original version, but without closure allocation in hash lookup - (define (memoize/key f key-fn statsbox) - (let ([ht (make-hash)] - [entries 0]) - (lambda (x y) - (if cache-size - (let* ([key (key-fn x y)]) - ;(record-cache-test! statsbox) - (unless (< entries cache-size) - (set! entries 0) - (set! ht (make-hash))) - (let ([ans (hash-ref ht key uniq)]) - (cond - [(eq? ans uniq) - ;(record-cache-miss! statsbox) - (set! entries (+ entries 1)) - (let ([res (f x y)]) - (hash-set! ht key res) - res)] - [else - ans]))) - (f x y))))) - - ;; hash version, but with an extra hash that tells when to evict cache entries - #; - (define (memoize/key f key-fn statsbox) - (let* ([cache-size 50] - [ht (make-hash)] - [uniq (gensym)] - [when-to-evict-table (make-hasheq)] - [pointer 0]) - (lambda (x y) - (record-cache-test! statsbox) - (let* ([key (key-fn x y)] - [value-in-cache (hash-ref ht key uniq)]) - (cond - [(eq? value-in-cache uniq) - (record-cache-miss! statsbox) - (let ([res (f x y)]) - (let ([to-remove (hash-ref when-to-evict-table pointer uniq)]) - (unless (eq? uniq to-remove) - (hash-remove! ht to-remove))) - (hash-set! when-to-evict-table pointer key) - (hash-set! ht key res) - (set! pointer (modulo (+ pointer 1) cache-size)) - res)] - [else - value-in-cache]))))) - - ;; lru cache - ;; for some reason, this seems to hit *less* than the "just dump stuff out" strategy! - #; - (define (memoize/key f key-fn statsbox) - (let* ([cache-size 50] - [cache '()]) - (lambda (x y) - (record-cache-test! statsbox) - (let ([key (key-fn x y)]) - (cond - [(null? cache) - ;; empty cache - (let ([ans (f x y)]) - (record-cache-miss! statsbox) - (set! cache (cons (cons key ans) '())) - ans)] - [(null? (cdr cache)) - ;; one element cache - (if (equal? (car (car cache)) key) - (cdr (car cache)) - (let ([ans (f x y)]) - (record-cache-miss! statsbox) - (set! cache (cons (cons key ans) cache)) - ans))] - [else - ;; two of more element cache +;; has-underscore? : symbol -> boolean +(define (has-underscore? sym) + (memq #\_ (string->list (symbol->string sym)))) + +;; symbol->nt : symbol -> symbol +;; strips the trailing underscore from a symbol, if one is there. +(define (symbol->nt sym) + (cond + [(has-underscore? sym) + (split-underscore sym)] + [else sym])) + +(define (memoize f needs-all-args?) + (if needs-all-args? + (memoize2 f) + (memoize1 f))) + +; memoize1 : (x y -> w) -> x y -> w +; memoizes a function of two arguments under the assumption +; that the function is constant w.r.t the second +(define (memoize1 f) (memoize/key f (lambda (x y) x) nohole)) +(define (memoize2 f) (memoize/key f cons w/hole)) + +(define cache-size 350) +(define (set-cache-size! cs) (set! cache-size cs)) + +;; original version, but without closure allocation in hash lookup +(define (memoize/key f key-fn statsbox) + (let ([ht (make-hash)] + [entries 0]) + (lambda (x y) + (cond + [(not (caching-enabled?)) (f x y)] + [else + (let* ([key (key-fn x y)]) + ;(record-cache-test! statsbox) + (unless (< entries cache-size) + (set! entries 0) + (set! ht (make-hash))) + (let ([ans (hash-ref ht key uniq)]) (cond - [(equal? (car (car cache)) key) - ;; check first element - (cdr (car cache))] - [(equal? (car (cadr cache)) key) - ;; check second element - (cdr (cadr cache))] + [(eq? ans uniq) + ;(record-cache-miss! statsbox) + (set! entries (+ entries 1)) + (let ([res (f x y)]) + (hash-set! ht key res) + res)] [else - ;; iterate from the 3rd element onwards - (let loop ([previous2 cache] - [previous1 (cdr cache)] - [current (cddr cache)] - [i 0]) - (cond - [(null? current) - ;; found the end of the cache -- need to drop the last element if the cache is too full, - ;; and put the current value at the front of the cache. - (let ([ans (f x y)]) - (record-cache-miss! statsbox) - (set! cache (cons (cons key ans) cache)) - (unless (< i cache-size) - ;; drop the last element from the cache - (set-cdr! previous2 '())) - ans)] - [else - (let ([entry (car current)]) - (cond - [(equal? (car entry) key) - ;; found a hit - - ; remove this element from the list where it is. - (set-cdr! previous1 (cdr current)) - - ; move it to the front of the cache - (set! cache (cons current cache)) - - ; return the found element - (cdr entry)] - [else - ;; didnt hit yet, continue searchign - (loop previous1 current (cdr current) (+ i 1))]))]))])]))))) - - ;; hash version, but with a vector that tells when to evict cache entries - #; - (define (memoize/key f key-fn statsbox) - (let* ([cache-size 50] - [ht (make-hash)] - [uniq (gensym)] - [vector (make-vector cache-size uniq)] ;; vector is only used to evict things from the hash - [pointer 0]) - (lambda (x y) - (let* ([key (key-fn x y)] - [value-in-cache (hash-ref ht key uniq)]) + ans])))])))) + +;; hash version, but with an extra hash that tells when to evict cache entries +#; +(define (memoize/key f key-fn statsbox) + (let* ([cache-size 50] + [ht (make-hash)] + [uniq (gensym)] + [when-to-evict-table (make-hasheq)] + [pointer 0]) + (lambda (x y) + (record-cache-test! statsbox) + (let* ([key (key-fn x y)] + [value-in-cache (hash-ref ht key uniq)]) + (cond + [(eq? value-in-cache uniq) + (record-cache-miss! statsbox) + (let ([res (f x y)]) + (let ([to-remove (hash-ref when-to-evict-table pointer uniq)]) + (unless (eq? uniq to-remove) + (hash-remove! ht to-remove))) + (hash-set! when-to-evict-table pointer key) + (hash-set! ht key res) + (set! pointer (modulo (+ pointer 1) cache-size)) + res)] + [else + value-in-cache]))))) + +;; lru cache +;; for some reason, this seems to hit *less* than the "just dump stuff out" strategy! +#; +(define (memoize/key f key-fn statsbox) + (let* ([cache-size 50] + [cache '()]) + (lambda (x y) + (record-cache-test! statsbox) + (let ([key (key-fn x y)]) + (cond + [(null? cache) + ;; empty cache + (let ([ans (f x y)]) + (record-cache-miss! statsbox) + (set! cache (cons (cons key ans) '())) + ans)] + [(null? (cdr cache)) + ;; one element cache + (if (equal? (car (car cache)) key) + (cdr (car cache)) + (let ([ans (f x y)]) + (record-cache-miss! statsbox) + (set! cache (cons (cons key ans) cache)) + ans))] + [else + ;; two of more element cache + (cond + [(equal? (car (car cache)) key) + ;; check first element + (cdr (car cache))] + [(equal? (car (cadr cache)) key) + ;; check second element + (cdr (cadr cache))] + [else + ;; iterate from the 3rd element onwards + (let loop ([previous2 cache] + [previous1 (cdr cache)] + [current (cddr cache)] + [i 0]) + (cond + [(null? current) + ;; found the end of the cache -- need to drop the last element if the cache is too full, + ;; and put the current value at the front of the cache. + (let ([ans (f x y)]) + (record-cache-miss! statsbox) + (set! cache (cons (cons key ans) cache)) + (unless (< i cache-size) + ;; drop the last element from the cache + (set-cdr! previous2 '())) + ans)] + [else + (let ([entry (car current)]) + (cond + [(equal? (car entry) key) + ;; found a hit + + ; remove this element from the list where it is. + (set-cdr! previous1 (cdr current)) + + ; move it to the front of the cache + (set! cache (cons current cache)) + + ; return the found element + (cdr entry)] + [else + ;; didnt hit yet, continue searchign + (loop previous1 current (cdr current) (+ i 1))]))]))])]))))) + +;; hash version, but with a vector that tells when to evict cache entries +#; +(define (memoize/key f key-fn statsbox) + (let* ([cache-size 50] + [ht (make-hash)] + [uniq (gensym)] + [vector (make-vector cache-size uniq)] ;; vector is only used to evict things from the hash + [pointer 0]) + (lambda (x y) + (let* ([key (key-fn x y)] + [value-in-cache (hash-ref ht key uniq)]) + (cond + [(eq? value-in-cache uniq) + (let ([res (f x y)]) + (let ([to-remove (vector-ref vector pointer)]) + (unless (eq? uniq to-remove) + (hash-remove! ht to-remove))) + (vector-set! vector pointer key) + (hash-set! ht key res) + (set! pointer (modulo (+ pointer 1) cache-size)) + res)] + [else + value-in-cache]))))) + +;; vector-based version, with a cleverer replacement strategy +#; +(define (memoize/key f key-fn statsbox) + (let* ([cache-size 20] + ;; cache : (vector-of (union #f (cons key val))) + ;; the #f correspond to empty spots in the cache + [cache (make-vector cache-size #f)] + [pointer 0]) + (lambda (x y) + (let ([key (key-fn x y)]) + (let loop ([i 0]) (cond - [(eq? value-in-cache uniq) - (let ([res (f x y)]) - (let ([to-remove (vector-ref vector pointer)]) - (unless (eq? uniq to-remove) - (hash-remove! ht to-remove))) - (vector-set! vector pointer key) - (hash-set! ht key res) - (set! pointer (modulo (+ pointer 1) cache-size)) - res)] + [(= i cache-size) + (unless (vector-ref cache pointer) + (vector-set! cache pointer (cons #f #f))) + (let ([pair (vector-ref cache pointer)] + [ans (f x y)]) + (set-car! pair key) + (set-cdr! pair ans) + (set! pointer (modulo (+ 1 pointer) cache-size)) + ans)] [else - value-in-cache]))))) - - ;; vector-based version, with a cleverer replacement strategy - #; - (define (memoize/key f key-fn statsbox) - (let* ([cache-size 20] - ;; cache : (vector-of (union #f (cons key val))) - ;; the #f correspond to empty spots in the cache - [cache (make-vector cache-size #f)] - [pointer 0]) - (lambda (x y) - (let ([key (key-fn x y)]) - (let loop ([i 0]) - (cond - [(= i cache-size) - (unless (vector-ref cache pointer) - (vector-set! cache pointer (cons #f #f))) - (let ([pair (vector-ref cache pointer)] - [ans (f x y)]) - (set-car! pair key) - (set-cdr! pair ans) - (set! pointer (modulo (+ 1 pointer) cache-size)) - ans)] - [else - (let ([entry (vector-ref cache i)]) - (if entry - (let ([e-key (car entry)] - [e-val (cdr entry)]) - (if (equal? e-key key) - e-val - (loop (+ i 1)))) - - ;; if we hit a #f, just skip ahead and store this in the cache - (loop cache-size)))])))))) - - ;; original version - #; - (define (memoize/key f key-fn statsbox) - (let ([ht (make-hash)] - [entries 0]) - (lambda (x y) - (record-cache-test! statsbox) - (let* ([key (key-fn x y)] - [compute/cache - (lambda () - (set! entries (+ entries 1)) - (record-cache-miss! statsbox) - (let ([res (f x y)]) - (hash-set! ht key res) - res))]) - (unless (< entries 200) ; 10000 was original size - (set! entries 0) - (set! ht (make-hash))) - (hash-ref ht key compute/cache))))) - - (define (record-cache-miss! statsbox) - (set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox))) - (set-cache-stats-misses! statsbox (add1 (cache-stats-misses statsbox)))) - - (define (record-cache-test! statsbox) - (set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox)))) - - (define-struct cache-stats (name misses hits) #:mutable) - (define (new-cache-stats name) (make-cache-stats name 0 0)) - - (define w/hole (new-cache-stats "hole")) - (define nohole (new-cache-stats "no-hole")) - - (define (print-stats) - (let ((stats (list w/hole nohole))) - (for-each - (lambda (s) - (when (> (+ (cache-stats-hits s) (cache-stats-misses s)) 0) - (printf "~a has ~a hits, ~a misses (~a% miss rate)\n" - (cache-stats-name s) - (cache-stats-hits s) - (cache-stats-misses s) - (floor - (* 100 (/ (cache-stats-misses s) - (+ (cache-stats-hits s) (cache-stats-misses s)))))))) - stats) - (let ((overall-hits (apply + (map cache-stats-hits stats))) - (overall-miss (apply + (map cache-stats-misses stats)))) - (printf "---\nOverall hits: ~a\n" overall-hits) - (printf "Overall misses: ~a\n" overall-miss) - (when (> (+ overall-hits overall-miss) 0) - (printf "Overall miss rate: ~a%\n" - (floor (* 100 (/ overall-miss (+ overall-hits overall-miss))))))))) - - ;; match-hole : (union none symbol) -> compiled-pattern - (define (match-hole hole-id) - (let ([mis-matched-hole - (λ (exp) - (and (hole? exp) - (list (make-mtch (make-bindings '()) - the-hole - none))))]) - (lambda (exp hole-info) - (if hole-info - (if (eq? hole-id hole-info) + (let ([entry (vector-ref cache i)]) + (if entry + (let ([e-key (car entry)] + [e-val (cdr entry)]) + (if (equal? e-key key) + e-val + (loop (+ i 1)))) + + ;; if we hit a #f, just skip ahead and store this in the cache + (loop cache-size)))])))))) + +;; original version +#; +(define (memoize/key f key-fn statsbox) + (let ([ht (make-hash)] + [entries 0]) + (lambda (x y) + (record-cache-test! statsbox) + (let* ([key (key-fn x y)] + [compute/cache + (lambda () + (set! entries (+ entries 1)) + (record-cache-miss! statsbox) + (let ([res (f x y)]) + (hash-set! ht key res) + res))]) + (unless (< entries 200) ; 10000 was original size + (set! entries 0) + (set! ht (make-hash))) + (hash-ref ht key compute/cache))))) + +(define (record-cache-miss! statsbox) + (set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox))) + (set-cache-stats-misses! statsbox (add1 (cache-stats-misses statsbox)))) + +(define (record-cache-test! statsbox) + (set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox)))) + +(define-struct cache-stats (name misses hits) #:mutable) +(define (new-cache-stats name) (make-cache-stats name 0 0)) + +(define w/hole (new-cache-stats "hole")) +(define nohole (new-cache-stats "no-hole")) + +(define (print-stats) + (let ((stats (list w/hole nohole))) + (for-each + (lambda (s) + (when (> (+ (cache-stats-hits s) (cache-stats-misses s)) 0) + (printf "~a has ~a hits, ~a misses (~a% miss rate)\n" + (cache-stats-name s) + (cache-stats-hits s) + (cache-stats-misses s) + (floor + (* 100 (/ (cache-stats-misses s) + (+ (cache-stats-hits s) (cache-stats-misses s)))))))) + stats) + (let ((overall-hits (apply + (map cache-stats-hits stats))) + (overall-miss (apply + (map cache-stats-misses stats)))) + (printf "---\nOverall hits: ~a\n" overall-hits) + (printf "Overall misses: ~a\n" overall-miss) + (when (> (+ overall-hits overall-miss) 0) + (printf "Overall miss rate: ~a%\n" + (floor (* 100 (/ overall-miss (+ overall-hits overall-miss))))))))) + +;; match-hole : (union none symbol) -> compiled-pattern +(define (match-hole hole-id) + (let ([mis-matched-hole + (λ (exp) + (and (hole? exp) (list (make-mtch (make-bindings '()) the-hole - exp)) - (mis-matched-hole exp)) - (mis-matched-hole exp))))) - - ;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern hole-info -> compiled-pattern - (define (match-in-hole context contractum exp match-context match-contractum hole-info) - (lambda (exp old-hole-info) - (let ([mtches (match-context exp hole-info)]) - (and mtches - (let loop ([mtches mtches] - [acc null]) - (cond - [(null? mtches) acc] - [else - (let* ([mtch (car mtches)] - [bindings (mtch-bindings mtch)] - [hole-exp (mtch-hole mtch)] - [contractum-mtches (match-contractum hole-exp old-hole-info)]) - (when (eq? none hole-exp) - (error 'matcher.ss "found zero holes when matching a decomposition")) - (if contractum-mtches - (let i-loop ([contractum-mtches contractum-mtches] - [acc acc]) - (cond - [(null? contractum-mtches) (loop (cdr mtches) acc)] - [else (let* ([contractum-mtch (car contractum-mtches)] - [contractum-bindings (mtch-bindings contractum-mtch)]) - (i-loop - (cdr contractum-mtches) - (cons - (make-mtch (make-bindings - (append (bindings-table contractum-bindings) - (bindings-table bindings))) - (build-nested-context - (mtch-context mtch) - (mtch-context contractum-mtch) - hole-info) - (mtch-hole contractum-mtch)) - acc)))])) - (loop (cdr mtches) acc)))])))))) - - ;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings)) - (define (match-list patterns exp hole-info) - (let (;; raw-match : (listof (listof (listof mtch))) - [raw-match (match-list/raw patterns exp hole-info)]) - - (and (not (null? raw-match)) - - (let* (;; combined-matches : (listof (listof mtch)) - ;; a list of complete possibilities for matches - ;; (analagous to multiple matches of a single non-terminal) - [combined-matches (map combine-matches raw-match)] - - ;; flattened-matches : (union #f (listof bindings)) - [flattened-matches (if (null? combined-matches) - #f - (apply append combined-matches))]) - flattened-matches)))) - - ;; match-list/raw : (listof (union repeat compiled-pattern)) - ;; sexp - ;; hole-info - ;; -> (listof (listof (listof mtch))) - ;; the result is the raw accumulation of the matches for each subpattern, as follows: - ;; (listof (listof (listof mtch))) - ;; \ \ \-------------/ a match for one position in the list (failures don't show up) - ;; \ \-------------------/ one element for each position in the pattern list - ;; \-------------------------/ one element for different expansions of the ellipses - ;; the failures to match are just removed from the outer list before this function finishes - ;; via the `fail' argument to `loop'. - (define (match-list/raw patterns exp hole-info) - (let/ec k - (let loop ([patterns patterns] - [exp exp] - ;; fail : -> alpha - ;; causes one possible expansion of ellipses to fail - ;; initially there is only one possible expansion, so - ;; everything fails. - [fail (lambda () (k null))]) - (cond - [(pair? patterns) - (let ([fst-pat (car patterns)]) + none))))]) + (lambda (exp hole-info) + (if hole-info + (if (eq? hole-id hole-info) + (list (make-mtch (make-bindings '()) + the-hole + exp)) + (mis-matched-hole exp)) + (mis-matched-hole exp))))) + +;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern hole-info -> compiled-pattern +(define (match-in-hole context contractum exp match-context match-contractum hole-info) + (lambda (exp old-hole-info) + (let ([mtches (match-context exp hole-info)]) + (and mtches + (let loop ([mtches mtches] + [acc null]) (cond - [(repeat? fst-pat) - (if (or (null? exp) (pair? exp)) - (let ([r-pat (repeat-pat fst-pat)] - [r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat)) - (build-flat-context '()) - none)]) - (apply - append - (cons (let/ec k - (let ([mt-fail (lambda () (k null))]) - (map (lambda (pat-ele) - (cons (add-ellipses-index (list r-mt) (repeat-suffix fst-pat) (repeat-mismatch? fst-pat) 0) - pat-ele)) - (loop (cdr patterns) exp mt-fail)))) - (let r-loop ([exp exp] - ;; past-matches is in reverse order - ;; it gets reversed before put into final list - [past-matches (list r-mt)] - [index 1]) - (cond - [(pair? exp) - (let* ([fst (car exp)] - [m (r-pat fst hole-info)]) - (if m - (let* ([combined-matches (collapse-single-multiples m past-matches)] - [reversed - (add-ellipses-index - (reverse-multiples combined-matches) - (repeat-suffix fst-pat) - (repeat-mismatch? fst-pat) - index)]) - (cons - (let/ec fail-k - (map (lambda (x) (cons reversed x)) - (loop (cdr patterns) - (cdr exp) - (lambda () (fail-k null))))) - (r-loop (cdr exp) - combined-matches - (+ index 1)))) - (list null)))] - ;; what about dotted pairs? - [else (list null)]))))) - (fail))] - [else - (cond - [(pair? exp) - (let* ([fst-exp (car exp)] - [match (fst-pat fst-exp hole-info)]) - (if match - (let ([exp-match (map (λ (mtch) (make-mtch (mtch-bindings mtch) - (build-list-context (mtch-context mtch)) - (mtch-hole mtch))) - match)]) - (map (lambda (x) (cons exp-match x)) - (loop (cdr patterns) (cdr exp) fail))) - (fail)))] - [else - (fail)])]))] - [else - (if (null? exp) - (list null) - (fail))])))) - - ;; add-ellipses-index : (listof mtch) sym boolean number -> (listof mtch) - (define (add-ellipses-index mtchs key mismatch-bind? i) - (if key - (let ([rib (if mismatch-bind? - (make-mismatch-bind key i) - (make-bind key i))]) - (map (λ (mtch) (make-mtch (make-bindings (cons rib (bindings-table (mtch-bindings mtch)))) - (mtch-context mtch) - (mtch-hole mtch))) - mtchs)) - mtchs)) - - ;; collapse-single-multiples : (listof mtch) (listof mtch[to-lists]) -> (listof mtch[to-lists]) - (define (collapse-single-multiples bindingss multiple-bindingss) - (apply append - (map - (lambda (multiple-match) - (let ([multiple-bindings (mtch-bindings multiple-match)]) - (map - (lambda (single-match) - (let ([single-bindings (mtch-bindings single-match)]) - (let ([rib-ht (make-hash)] - [mismatch-rib-ht (make-hash)]) - (for-each - (lambda (multiple-rib) - (cond - [(bind? multiple-rib) - (hash-set! rib-ht (bind-name multiple-rib) (bind-exp multiple-rib))] - [(mismatch-bind? multiple-rib) - (hash-set! mismatch-rib-ht (mismatch-bind-name multiple-rib) (mismatch-bind-exp multiple-rib))])) - (bindings-table multiple-bindings)) - (for-each - (lambda (single-rib) - (cond - [(bind? single-rib) - (let* ([key (bind-name single-rib)] - [rst (hash-ref rib-ht key '())]) - (hash-set! rib-ht key (cons (bind-exp single-rib) rst)))] - [(mismatch-bind? single-rib) - (let* ([key (mismatch-bind-name single-rib)] - [rst (hash-ref mismatch-rib-ht key '())]) - (hash-set! mismatch-rib-ht key (cons (mismatch-bind-exp single-rib) rst)))])) - (bindings-table single-bindings)) - (make-mtch (make-bindings (append (hash-map rib-ht make-bind) - (hash-map mismatch-rib-ht make-mismatch-bind))) - (build-cons-context - (mtch-context single-match) - (mtch-context multiple-match)) - (pick-hole (mtch-hole single-match) - (mtch-hole multiple-match)))))) - bindingss))) - multiple-bindingss))) - - ;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp) - (define (pick-hole s1 s2) - (cond - [(eq? none s1) s2] - [(eq? none s2) s1] - [(error 'matcher.ss "found two holes")])) - - ;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists]) - ;; reverses the rhs of each rib in the bindings and reverses the context. - (define (reverse-multiples matches) - (map (lambda (match) - (let ([bindings (mtch-bindings match)]) - (make-mtch - (make-bindings - (map (lambda (rib) - (cond - [(bind? rib) - (make-bind (bind-name rib) - (reverse (bind-exp rib)))] - [(mismatch-bind? rib) - (make-mismatch-bind (mismatch-bind-name rib) - (reverse (mismatch-bind-exp rib)))])) - (bindings-table bindings))) - (reverse-context (mtch-context match)) - (mtch-hole match)))) - matches)) - - ;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info - ;; -> (union #f (listof bindings)) - (define (match-nt list-rhs non-list-rhs nt term hole-info) - (let loop ([rhss (if (or (null? term) (pair? term)) - list-rhs - non-list-rhs)] - [ht #f]) + [(null? mtches) acc] + [else + (let* ([mtch (car mtches)] + [bindings (mtch-bindings mtch)] + [hole-exp (mtch-hole mtch)] + [contractum-mtches (match-contractum hole-exp old-hole-info)]) + (when (eq? none hole-exp) + (error 'matcher.ss "found zero holes when matching a decomposition")) + (if contractum-mtches + (let i-loop ([contractum-mtches contractum-mtches] + [acc acc]) + (cond + [(null? contractum-mtches) (loop (cdr mtches) acc)] + [else (let* ([contractum-mtch (car contractum-mtches)] + [contractum-bindings (mtch-bindings contractum-mtch)]) + (i-loop + (cdr contractum-mtches) + (cons + (make-mtch (make-bindings + (append (bindings-table contractum-bindings) + (bindings-table bindings))) + (build-nested-context + (mtch-context mtch) + (mtch-context contractum-mtch) + hole-info) + (mtch-hole contractum-mtch)) + acc)))])) + (loop (cdr mtches) acc)))])))))) + +;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings)) +(define (match-list patterns exp hole-info) + (let (;; raw-match : (listof (listof (listof mtch))) + [raw-match (match-list/raw patterns exp hole-info)]) + + (and (not (null? raw-match)) + + (let* (;; combined-matches : (listof (listof mtch)) + ;; a list of complete possibilities for matches + ;; (analagous to multiple matches of a single non-terminal) + [combined-matches (map combine-matches raw-match)] + + ;; flattened-matches : (union #f (listof bindings)) + [flattened-matches (if (null? combined-matches) + #f + (apply append combined-matches))]) + flattened-matches)))) + +;; match-list/raw : (listof (union repeat compiled-pattern)) +;; sexp +;; hole-info +;; -> (listof (listof (listof mtch))) +;; the result is the raw accumulation of the matches for each subpattern, as follows: +;; (listof (listof (listof mtch))) +;; \ \ \-------------/ a match for one position in the list (failures don't show up) +;; \ \-------------------/ one element for each position in the pattern list +;; \-------------------------/ one element for different expansions of the ellipses +;; the failures to match are just removed from the outer list before this function finishes +;; via the `fail' argument to `loop'. +(define (match-list/raw patterns exp hole-info) + (let/ec k + (let loop ([patterns patterns] + [exp exp] + ;; fail : -> alpha + ;; causes one possible expansion of ellipses to fail + ;; initially there is only one possible expansion, so + ;; everything fails. + [fail (lambda () (k null))]) (cond - [(null? rhss) - (if ht - (hash-map ht (λ (k v) k)) - #f)] - [else - (let ([mth (remove-bindings/filter ((car rhss) term hole-info))]) + [(pair? patterns) + (let ([fst-pat (car patterns)]) (cond - [mth - (let ([ht (or ht (make-hash))]) - (for-each (λ (x) (hash-set! ht x #t)) mth) - (loop (cdr rhss) ht))] - [else - (loop (cdr rhss) ht)]))]))) - - ;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch)) - (define (remove-bindings/filter matches) - (and matches - (let ([filtered (filter-multiples matches)]) - (and (not (null? filtered)) - (map (λ (match) - (make-mtch (make-bindings '()) - (mtch-context match) - (mtch-hole match))) - matches))))) - - ;; rewrite-ellipses : (symbol -> boolean) - ;; (listof pattern) - ;; (pattern -> (values compiled-pattern boolean)) - ;; -> (values (listof (union repeat compiled-pattern)) boolean) - ;; moves the ellipses out of the list and produces repeat structures - (define (rewrite-ellipses non-underscore-binder? pattern compile) - (let loop ([exp-eles pattern] - [fst dummy]) - (cond - [(null? exp-eles) - (if (eq? fst dummy) - (values empty #f) - (let-values ([(compiled has-hole?) (compile fst)]) - (values (list compiled) has-hole?)))] - [else - (let ([exp-ele (car exp-eles)]) - (cond - [(or (eq? '... exp-ele) - (prefixed-with? "..._" exp-ele)) - (when (eq? fst dummy) - (error 'match-pattern "bad ellipses placement: ~s" pattern)) - (let-values ([(compiled has-hole?) (compile fst)] - [(rest rest-has-hole?) (loop (cdr exp-eles) dummy)]) - (let ([underscore-key (if (eq? exp-ele '...) #f exp-ele)] - [mismatch? (and (regexp-match #rx"_!_" (symbol->string exp-ele)) #t)]) - (values - (cons (make-repeat compiled (extract-empty-bindings non-underscore-binder? fst) underscore-key mismatch?) - rest) - (or has-hole? rest-has-hole?))))] - [(eq? fst dummy) - (loop (cdr exp-eles) exp-ele)] + [(repeat? fst-pat) + (if (or (null? exp) (pair? exp)) + (let ([r-pat (repeat-pat fst-pat)] + [r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat)) + (build-flat-context '()) + none)]) + (apply + append + (cons (let/ec k + (let ([mt-fail (lambda () (k null))]) + (map (lambda (pat-ele) + (cons (add-ellipses-index (list r-mt) (repeat-suffix fst-pat) (repeat-mismatch? fst-pat) 0) + pat-ele)) + (loop (cdr patterns) exp mt-fail)))) + (let r-loop ([exp exp] + ;; past-matches is in reverse order + ;; it gets reversed before put into final list + [past-matches (list r-mt)] + [index 1]) + (cond + [(pair? exp) + (let* ([fst (car exp)] + [m (r-pat fst hole-info)]) + (if m + (let* ([combined-matches (collapse-single-multiples m past-matches)] + [reversed + (add-ellipses-index + (reverse-multiples combined-matches) + (repeat-suffix fst-pat) + (repeat-mismatch? fst-pat) + index)]) + (cons + (let/ec fail-k + (map (lambda (x) (cons reversed x)) + (loop (cdr patterns) + (cdr exp) + (lambda () (fail-k null))))) + (r-loop (cdr exp) + combined-matches + (+ index 1)))) + (list null)))] + ;; what about dotted pairs? + [else (list null)]))))) + (fail))] [else - (let-values ([(compiled has-hole?) (compile fst)] - [(rest rest-has-hole?) (loop (cdr exp-eles) exp-ele)]) - (values - (cons compiled rest) - (or has-hole? rest-has-hole?)))]))]))) - - (define (prefixed-with? prefix exp) - (and (symbol? exp) - (let* ([str (symbol->string exp)] - [len (string-length str)]) - (and (len . >= . (string-length prefix)) - (string=? (substring str 0 (string-length prefix)) - prefix))))) - - (define dummy (box 0)) - - ;; extract-empty-bindings : (symbol -> boolean) pattern -> (listof rib) - (define (extract-empty-bindings non-underscore-binder? pattern) - (let loop ([pattern pattern] - [ribs null]) - (match pattern - [`(variable-except ,vars ...) ribs] - [`(variable-prefix ,vars) ribs] - [`variable-not-otherwise-mentioned ribs] - - [`hole (error 'match-pattern "cannot have a hole inside an ellipses")] - [(? symbol?) - (cond - [(regexp-match #rx"_!_" (symbol->string pattern)) - (cons (make-mismatch-bind pattern '()) ribs)] - [(or (has-underscore? pattern) - (non-underscore-binder? pattern)) - (cons (make-bind pattern '()) ribs)] - [else ribs])] - [`(name ,name ,pat) - (if (regexp-match #rx"_!_" (symbol->string name)) - (loop pat (cons (make-mismatch-bind name '()) ribs)) - (loop pat (cons (make-bind name '()) ribs)))] - [`(in-hole ,context ,contractum) (loop context (loop contractum ribs))] - [`(hide-hole ,p) (loop p ribs)] - [`(side-condition ,pat ,test) (loop pat ribs)] - [(? list?) - (let-values ([(rewritten has-hole?) (rewrite-ellipses non-underscore-binder? pattern (lambda (x) (values x #f)))]) - (let i-loop ([r-exps rewritten] - [ribs ribs]) - (cond - [(null? r-exps) ribs] - [else (let ([r-exp (car r-exps)]) - (cond - [(repeat? r-exp) - (i-loop - (cdr r-exps) - (append (repeat-empty-bindings r-exp) ribs))] - [else - (i-loop - (cdr r-exps) - (loop (car r-exps) ribs))]))])))] - [else ribs]))) - - ;; combine-matches : (listof (listof mtch)) -> (listof mtch) - ;; input is the list of bindings corresonding to a piecewise match - ;; of a list. produces all of the combinations of complete matches - (define (combine-matches matchess) - (let loop ([matchess matchess]) - (cond - [(null? matchess) (list (make-mtch (make-bindings null) (build-flat-context '()) none))] - [else (combine-pair (car matchess) (loop (cdr matchess)))]))) - - ;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch) - (define (combine-pair fst snd) - (let ([mtchs null]) - (for-each - (lambda (mtch1) - (for-each - (lambda (mtch2) - (set! mtchs (cons (make-mtch - (make-bindings (append (bindings-table (mtch-bindings mtch1)) - (bindings-table (mtch-bindings mtch2)))) - (build-append-context (mtch-context mtch1) (mtch-context mtch2)) - (pick-hole (mtch-hole mtch1) - (mtch-hole mtch2))) - mtchs))) - snd)) - fst) + (cond + [(pair? exp) + (let* ([fst-exp (car exp)] + [match (fst-pat fst-exp hole-info)]) + (if match + (let ([exp-match (map (λ (mtch) (make-mtch (mtch-bindings mtch) + (build-list-context (mtch-context mtch)) + (mtch-hole mtch))) + match)]) + (map (lambda (x) (cons exp-match x)) + (loop (cdr patterns) (cdr exp) fail))) + (fail)))] + [else + (fail)])]))] + [else + (if (null? exp) + (list null) + (fail))])))) + +;; add-ellipses-index : (listof mtch) sym boolean number -> (listof mtch) +(define (add-ellipses-index mtchs key mismatch-bind? i) + (if key + (let ([rib (if mismatch-bind? + (make-mismatch-bind key i) + (make-bind key i))]) + (map (λ (mtch) (make-mtch (make-bindings (cons rib (bindings-table (mtch-bindings mtch)))) + (mtch-context mtch) + (mtch-hole mtch))) + mtchs)) mtchs)) - - (define (hash-maps? ht key) - (not (eq? (hash-ref ht key uniq) uniq))) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; context adt - ;; - - #| + +;; collapse-single-multiples : (listof mtch) (listof mtch[to-lists]) -> (listof mtch[to-lists]) +(define (collapse-single-multiples bindingss multiple-bindingss) + (apply append + (map + (lambda (multiple-match) + (let ([multiple-bindings (mtch-bindings multiple-match)]) + (map + (lambda (single-match) + (let ([single-bindings (mtch-bindings single-match)]) + (let ([rib-ht (make-hash)] + [mismatch-rib-ht (make-hash)]) + (for-each + (lambda (multiple-rib) + (cond + [(bind? multiple-rib) + (hash-set! rib-ht (bind-name multiple-rib) (bind-exp multiple-rib))] + [(mismatch-bind? multiple-rib) + (hash-set! mismatch-rib-ht (mismatch-bind-name multiple-rib) (mismatch-bind-exp multiple-rib))])) + (bindings-table multiple-bindings)) + (for-each + (lambda (single-rib) + (cond + [(bind? single-rib) + (let* ([key (bind-name single-rib)] + [rst (hash-ref rib-ht key '())]) + (hash-set! rib-ht key (cons (bind-exp single-rib) rst)))] + [(mismatch-bind? single-rib) + (let* ([key (mismatch-bind-name single-rib)] + [rst (hash-ref mismatch-rib-ht key '())]) + (hash-set! mismatch-rib-ht key (cons (mismatch-bind-exp single-rib) rst)))])) + (bindings-table single-bindings)) + (make-mtch (make-bindings (append (hash-map rib-ht make-bind) + (hash-map mismatch-rib-ht make-mismatch-bind))) + (build-cons-context + (mtch-context single-match) + (mtch-context multiple-match)) + (pick-hole (mtch-hole single-match) + (mtch-hole multiple-match)))))) + bindingss))) + multiple-bindingss))) + +;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp) +(define (pick-hole s1 s2) + (cond + [(eq? none s1) s2] + [(eq? none s2) s1] + [(error 'matcher.ss "found two holes")])) + +;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists]) +;; reverses the rhs of each rib in the bindings and reverses the context. +(define (reverse-multiples matches) + (map (lambda (match) + (let ([bindings (mtch-bindings match)]) + (make-mtch + (make-bindings + (map (lambda (rib) + (cond + [(bind? rib) + (make-bind (bind-name rib) + (reverse (bind-exp rib)))] + [(mismatch-bind? rib) + (make-mismatch-bind (mismatch-bind-name rib) + (reverse (mismatch-bind-exp rib)))])) + (bindings-table bindings))) + (reverse-context (mtch-context match)) + (mtch-hole match)))) + matches)) + +;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info +;; -> (union #f (listof bindings)) +(define (match-nt list-rhs non-list-rhs nt term hole-info) + (let loop ([rhss (if (or (null? term) (pair? term)) + list-rhs + non-list-rhs)] + [ht #f]) + (cond + [(null? rhss) + (if ht + (hash-map ht (λ (k v) k)) + #f)] + [else + (let ([mth (remove-bindings/filter ((car rhss) term hole-info))]) + (cond + [mth + (let ([ht (or ht (make-hash))]) + (for-each (λ (x) (hash-set! ht x #t)) mth) + (loop (cdr rhss) ht))] + [else + (loop (cdr rhss) ht)]))]))) + +;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch)) +(define (remove-bindings/filter matches) + (and matches + (let ([filtered (filter-multiples matches)]) + (and (not (null? filtered)) + (map (λ (match) + (make-mtch (make-bindings '()) + (mtch-context match) + (mtch-hole match))) + matches))))) + +;; rewrite-ellipses : (symbol -> boolean) +;; (listof pattern) +;; (pattern -> (values compiled-pattern boolean)) +;; -> (values (listof (union repeat compiled-pattern)) boolean) +;; moves the ellipses out of the list and produces repeat structures +(define (rewrite-ellipses non-underscore-binder? pattern compile) + (let loop ([exp-eles pattern] + [fst dummy]) + (cond + [(null? exp-eles) + (if (eq? fst dummy) + (values empty #f) + (let-values ([(compiled has-hole?) (compile fst)]) + (values (list compiled) has-hole?)))] + [else + (let ([exp-ele (car exp-eles)]) + (cond + [(or (eq? '... exp-ele) + (prefixed-with? "..._" exp-ele)) + (when (eq? fst dummy) + (error 'match-pattern "bad ellipses placement: ~s" pattern)) + (let-values ([(compiled has-hole?) (compile fst)] + [(rest rest-has-hole?) (loop (cdr exp-eles) dummy)]) + (let ([underscore-key (if (eq? exp-ele '...) #f exp-ele)] + [mismatch? (and (regexp-match #rx"_!_" (symbol->string exp-ele)) #t)]) + (values + (cons (make-repeat compiled (extract-empty-bindings non-underscore-binder? fst) underscore-key mismatch?) + rest) + (or has-hole? rest-has-hole?))))] + [(eq? fst dummy) + (loop (cdr exp-eles) exp-ele)] + [else + (let-values ([(compiled has-hole?) (compile fst)] + [(rest rest-has-hole?) (loop (cdr exp-eles) exp-ele)]) + (values + (cons compiled rest) + (or has-hole? rest-has-hole?)))]))]))) + +(define (prefixed-with? prefix exp) + (and (symbol? exp) + (let* ([str (symbol->string exp)] + [len (string-length str)]) + (and (len . >= . (string-length prefix)) + (string=? (substring str 0 (string-length prefix)) + prefix))))) + +(define dummy (box 0)) + +;; extract-empty-bindings : (symbol -> boolean) pattern -> (listof rib) +(define (extract-empty-bindings non-underscore-binder? pattern) + (let loop ([pattern pattern] + [ribs null]) + (match pattern + [`(variable-except ,vars ...) ribs] + [`(variable-prefix ,vars) ribs] + [`variable-not-otherwise-mentioned ribs] + + [`hole (error 'match-pattern "cannot have a hole inside an ellipses")] + [(? symbol?) + (cond + [(regexp-match #rx"_!_" (symbol->string pattern)) + (cons (make-mismatch-bind pattern '()) ribs)] + [(or (has-underscore? pattern) + (non-underscore-binder? pattern)) + (cons (make-bind pattern '()) ribs)] + [else ribs])] + [`(name ,name ,pat) + (if (regexp-match #rx"_!_" (symbol->string name)) + (loop pat (cons (make-mismatch-bind name '()) ribs)) + (loop pat (cons (make-bind name '()) ribs)))] + [`(in-hole ,context ,contractum) (loop context (loop contractum ribs))] + [`(hide-hole ,p) (loop p ribs)] + [`(side-condition ,pat ,test) (loop pat ribs)] + [(? list?) + (let-values ([(rewritten has-hole?) (rewrite-ellipses non-underscore-binder? pattern (lambda (x) (values x #f)))]) + (let i-loop ([r-exps rewritten] + [ribs ribs]) + (cond + [(null? r-exps) ribs] + [else (let ([r-exp (car r-exps)]) + (cond + [(repeat? r-exp) + (i-loop + (cdr r-exps) + (append (repeat-empty-bindings r-exp) ribs))] + [else + (i-loop + (cdr r-exps) + (loop (car r-exps) ribs))]))])))] + [else ribs]))) + +;; combine-matches : (listof (listof mtch)) -> (listof mtch) +;; input is the list of bindings corresonding to a piecewise match +;; of a list. produces all of the combinations of complete matches +(define (combine-matches matchess) + (let loop ([matchess matchess]) + (cond + [(null? matchess) (list (make-mtch (make-bindings null) (build-flat-context '()) none))] + [else (combine-pair (car matchess) (loop (cdr matchess)))]))) + +;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch) +(define (combine-pair fst snd) + (let ([mtchs null]) + (for-each + (lambda (mtch1) + (for-each + (lambda (mtch2) + (set! mtchs (cons (make-mtch + (make-bindings (append (bindings-table (mtch-bindings mtch1)) + (bindings-table (mtch-bindings mtch2)))) + (build-append-context (mtch-context mtch1) (mtch-context mtch2)) + (pick-hole (mtch-hole mtch1) + (mtch-hole mtch2))) + mtchs))) + snd)) + fst) + mtchs)) + +(define (hash-maps? ht key) + (not (eq? (hash-ref ht key uniq) uniq))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; context adt +;; + +#| ;; This version of the ADT isn't right yet -- ;; need to figure out what to do about (name ...) patterns. @@ -1536,91 +1539,92 @@ before the pattern compiler is invoked. (define (reverse-context c) (make-context (lambda (x) (reverse (c x))))) |# - (define (context? x) #t) - (define-values (the-hole hole?) - (let () - (define-struct hole () #:inspector #f) - (define the-hole (make-hole)) - (values the-hole hole?))) - - (define (build-flat-context exp) exp) - (define (build-cons-context e1 e2) (cons e1 e2)) - (define (build-append-context e1 e2) (append e1 e2)) - (define (build-list-context x) (list x)) - (define (reverse-context x) (reverse x)) - (define (build-nested-context c1 c2 hole-info) - (plug c1 c2 hole-info)) - (define plug - (case-lambda - [(exp hole-stuff) (plug exp hole-stuff none)] - [(exp hole-stuff hole-info) - (let ([done? #f]) - (let loop ([exp exp]) - (cond - [(pair? exp) - (cons (loop (car exp)) - (if done? - (cdr exp) - (loop (cdr exp))))] - - [(hole? exp) - (set! done? #t) - hole-stuff] - [else exp])))])) - - ;; - ;; end context adt - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; used in hash lookups to tell when something isn't in the table - (define uniq (gensym)) - - (provide/contract - (match-pattern (compiled-pattern? any/c . -> . (or/c false/c (listof mtch?)))) - (compile-pattern (-> compiled-lang? any/c boolean? - compiled-pattern?)) +(define (context? x) #t) +(define-values (the-hole hole?) + (let () + (define-struct hole () #:inspector #f) + (define the-hole (make-hole)) + (values the-hole hole?))) - (set-cache-size! (-> (or/c false/c (and/c integer? positive?)) void?)) - - (make-bindings ((listof bind?) . -> . bindings?)) - (bindings-table (bindings? . -> . (listof bind?))) - (bindings? (any/c . -> . boolean?)) - - (mtch? (any/c . -> . boolean?)) - (make-mtch (bindings? any/c any/c . -> . mtch?)) - (mtch-bindings (mtch? . -> . bindings?)) - (mtch-context (mtch? . -> . any/c)) - (mtch-hole (mtch? . -> . (or/c none? any/c))) - - (make-bind (symbol? any/c . -> . bind?)) - (bind? (any/c . -> . boolean?)) - (bind-name (bind? . -> . symbol?)) - (bind-exp (bind? . -> . any/c)) - (compile-language (-> any/c (listof nt?) (listof (listof symbol?)) compiled-lang?)) - (symbol->nt (symbol? . -> . symbol?)) - (has-underscore? (symbol? . -> . boolean?)) - (split-underscore (symbol? . -> . symbol?))) - (provide compiled-pattern? - print-stats) - - ;; for test suite - (provide build-cons-context - build-flat-context - context?) - - (provide (struct-out nt) - (struct-out rhs) - (struct-out compiled-lang) +(define (build-flat-context exp) exp) +(define (build-cons-context e1 e2) (cons e1 e2)) +(define (build-append-context e1 e2) (append e1 e2)) +(define (build-list-context x) (list x)) +(define (reverse-context x) (reverse x)) +(define (build-nested-context c1 c2 hole-info) + (plug c1 c2 hole-info)) +(define plug + (case-lambda + [(exp hole-stuff) (plug exp hole-stuff none)] + [(exp hole-stuff hole-info) + (let ([done? #f]) + (let loop ([exp exp]) + (cond + [(pair? exp) + (cons (loop (car exp)) + (if done? + (cdr exp) + (loop (cdr exp))))] - lookup-binding - - compiled-pattern - - plug - none? none - - make-repeat - the-hole hole? - rewrite-ellipses - build-compatible-context-language) \ No newline at end of file + [(hole? exp) + (set! done? #t) + hole-stuff] + [else exp])))])) + +;; +;; end context adt +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; used in hash lookups to tell when something isn't in the table +(define uniq (gensym)) + +(provide/contract + (match-pattern (compiled-pattern? any/c . -> . (or/c false/c (listof mtch?)))) + (compile-pattern (-> compiled-lang? any/c boolean? + compiled-pattern?)) + + (set-cache-size! (-> (and/c integer? positive?) void?)) + + (make-bindings ((listof bind?) . -> . bindings?)) + (bindings-table (bindings? . -> . (listof bind?))) + (bindings? (any/c . -> . boolean?)) + + (mtch? (any/c . -> . boolean?)) + (make-mtch (bindings? any/c any/c . -> . mtch?)) + (mtch-bindings (mtch? . -> . bindings?)) + (mtch-context (mtch? . -> . any/c)) + (mtch-hole (mtch? . -> . (or/c none? any/c))) + + (make-bind (symbol? any/c . -> . bind?)) + (bind? (any/c . -> . boolean?)) + (bind-name (bind? . -> . symbol?)) + (bind-exp (bind? . -> . any/c)) + (compile-language (-> any/c (listof nt?) (listof (listof symbol?)) compiled-lang?)) + (symbol->nt (symbol? . -> . symbol?)) + (has-underscore? (symbol? . -> . boolean?)) + (split-underscore (symbol? . -> . symbol?))) +(provide compiled-pattern? + print-stats) + +;; for test suite +(provide build-cons-context + build-flat-context + context?) + +(provide (struct-out nt) + (struct-out rhs) + (struct-out compiled-lang) + + lookup-binding + + compiled-pattern + + plug + none? none + + make-repeat + the-hole hole? + rewrite-ellipses + build-compatible-context-language + caching-enabled?) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 73cc3ad64c..00d009ee78 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -1136,7 +1136,7 @@ (λ (exp) (let ([cache-ref (hash-ref cache exp not-in-cache)]) (cond - [(eq? cache-ref not-in-cache) + [(or (not (caching-enabled?)) (eq? cache-ref not-in-cache)) (when dom-compiled-pattern (unless (match-pattern dom-compiled-pattern exp) (redex-error name diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index 0bbb62e414..7c0c109f48 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -195,6 +195,45 @@ #t)) + ;; test caching + (let () + (define match? #t) + + (define-language lang + (x (side-condition any match?))) + + (test (pair? (redex-match lang x 1)) #t) + (set! match? #f) + (test (pair? (redex-match lang x 1)) #t) + (parameterize ([caching-enabled? #f]) + (test (pair? (redex-match lang x 1)) #f))) + + + (let () + (define sc-eval-count 0) + (define-language lang + (x (side-condition any (begin (set! sc-eval-count (+ sc-eval-count 1)) + #t)))) + + (redex-match lang x 1) + (redex-match lang x 1) + (parameterize ([caching-enabled? #f]) + (redex-match lang x 1)) + (test sc-eval-count 2)) + + (let () + (define rhs-eval-count 0) + (define-metafunction empty-language + [(f any) ,(begin (set! rhs-eval-count (+ rhs-eval-count 1)) + 1)]) + + (term (f 1)) + (term (f 1)) + (parameterize ([caching-enabled? #f]) + (term (f 1))) + (test rhs-eval-count 2)) + + ; ; ; ;;; ; diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 4dc2dc7d97..3f6b0f75e0 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -328,16 +328,28 @@ clause is followed by an ellipsis. Nested ellipses produce nested lists. } -@defproc[(set-cache-size! [size (or/c false/c positive-integer?)]) void?]{ +@defproc[(set-cache-size! [size positive-integer?]) void?]{ -Changes the cache size; a #f disables the cache -entirely. The default size is 350. +Changes the cache size; the default size is @scheme[350]. -The cache is per-pattern (ie, each pattern has a cache of -size at most 350 (by default)) and is a simple table that -maps expressions to how they matched the pattern. When the -cache gets full, it is thrown away and a new cache is -started. +The cache is per-pattern (ie, each pattern has a cache of size at most +350 (by default)) and is a simple table that maps expressions to how +they matched the pattern (ie, the bindings for the pattern +variables). When the cache gets full, it is thrown away and a new +cache is started. +} + +@defparam[caching-enabled? on? boolean?]{ + This is a parameter that controls whether or not a cache + is consulted (and updated) while matching and while evaluating + metafunctions. + + If it is @scheme[#t], then side-conditions and the right-hand sides + of metafunctions are assumed to only depend on the values of the + pattern variables in scope (and thus not on any other external + state). + + Defaults to @scheme[#t]. } @section{Terms} @@ -859,7 +871,8 @@ no clauses match, if one of the clauses matches multiple ways, or if the contract is violated. Note that metafunctions are assumed to always return the same results -for the same inputs, and their results are cached. Accordingly, if a +for the same inputs, and their results are cached, unless +@scheme[caching-enable?] is set to @scheme[#f]. Accordingly, if a metafunction is called with the same inputs twice, then its body is only evaluated a single time. diff --git a/collects/redex/reduction-semantics.ss b/collects/redex/reduction-semantics.ss index 96885b50e4..7a477f2cb8 100644 --- a/collects/redex/reduction-semantics.ss +++ b/collects/redex/reduction-semantics.ss @@ -29,7 +29,9 @@ define-metafunction define-metafunction/extension metafunction - in-domain?) + in-domain? + + caching-enabled?) (provide (rename-out [test-match redex-match]) term-match From fe62b9713724580ab2400b882924847a215c4fc8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 7 Jan 2009 08:50:14 +0000 Subject: [PATCH 40/49] Welcome to a new PLT day. svn: r13026 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 4599b43c3d..c637c6f355 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "6jan2009") +#lang scheme/base (provide stamp) (define stamp "7jan2009") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 36cd703726..2e9bb4a4bf 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Wed, 7 Jan 2009 15:44:07 +0000 Subject: [PATCH 41/49] opened up the trace library a little more to make it more useable for Redex svn: r13027 --- collects/mzlib/scribblings/trace.scrbl | 23 ++++++++++ collects/mzlib/trace.ss | 58 +++++++++++++------------- 2 files changed, 52 insertions(+), 29 deletions(-) diff --git a/collects/mzlib/scribblings/trace.scrbl b/collects/mzlib/scribblings/trace.scrbl index d63795242b..148a86f9a9 100644 --- a/collects/mzlib/scribblings/trace.scrbl +++ b/collects/mzlib/scribblings/trace.scrbl @@ -56,3 +56,26 @@ end with a newline, but it may contain internal newlines. Each call or result is converted into a string using @scheme[pretty-print]. The parameter's default value prints the given string followed by a newline to @scheme[(current-output-port)].} + +@defproc[(trace-apply [id symbol?] [proc procedure?] [kws (listof keyword)] [kw-vals list?] [arg any/c] ...) any/c]{ + +Calls @scheme[proc] with the arguments supplied in +@scheme[args], @scheme[kws], and @scheme[kw-vals]. Also prints out the +trace information during the call, as described above in the docs for +@scheme[trace], using @scheme[id] as the name of @scheme[proc]. + +} + +@defparam[current-trace-print-args trace-print-args + (-> symbol? + (listof keyword?) + list? + list? + number?)]{ + +The value of this parameter is invoked to print out the arguments of a +traced call. It receives the name of the function, the function's +ordinary arguments, its keywords, the values of the keywords, and a +number indicating the depth of the call. + +} \ No newline at end of file diff --git a/collects/mzlib/trace.ss b/collects/mzlib/trace.ss index e04c657ad6..21c47e026c 100644 --- a/collects/mzlib/trace.ss +++ b/collects/mzlib/trace.ss @@ -4,19 +4,16 @@ (for-syntax scheme/base)) (provide trace untrace + current-trace-print-args trace-apply current-trace-notify) (define max-dash-space-depth 10) (define number-nesting-depth 6) - (define as-spaces - (lambda (s) - (let ((n (string-length s))) - (apply string-append - (let loop ((k n)) - (if (zero? k) '("") - (cons " " (loop (sub1 k))))))))) - + (define (as-spaces s) + (build-string (string-length s) + (lambda (i) #\space))) + (define-struct prefix-entry (for-first for-rest)) (define prefixes (make-vector 20 #f)) @@ -101,28 +98,29 @@ (lambda (name args kws kw-vals level) (as-trace-notify (lambda () - (trace-print-args name args kws kw-vals level))))) - - (define trace-print-args - (lambda (name args kws kw-vals level) - (let-values (((first rest) - (build-prefixes level))) - (parameterize ((pretty-print-print-line - (lambda (n port offset width) - (display - (if n - (if (zero? n) first - (format "~n~a" rest)) - (format "~n")) - port) - (if n - (if (zero? n) - (string-length first) - (string-length rest)) - 0)))) - (pretty-print (append (cons name args) - (apply append (map list kws kw-vals)))))))) + ((current-trace-print-args) name args kws kw-vals level))))) + (define current-trace-print-args + (make-parameter + (lambda (name args kws kw-vals level) + (let-values (((first rest) + (build-prefixes level))) + (parameterize ((pretty-print-print-line + (lambda (n port offset width) + (display + (if n + (if (zero? n) first + (format "~n~a" rest)) + (format "~n")) + port) + (if n + (if (zero? n) + (string-length first) + (string-length rest)) + 0)))) + (pretty-print (append (cons name args) + (apply append (map list kws kw-vals))))))))) + (define -:trace-print-results (lambda (name results level) (as-trace-notify @@ -197,6 +195,8 @@ ;; the nesting depth: (define -:trace-level-key (gensym)) + (define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f)) + ;; Apply a traced procedure to arguments, printing arguments ;; and results. We set and inspect the -:trace-level-key continuation ;; mark a few times to detect tail calls. From 05160bf9317a8c12ec65177aadc351be0bb2d5d2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Jan 2009 15:55:21 +0000 Subject: [PATCH 42/49] PR 10009 and added tracing to metafunctions svn: r13028 --- collects/redex/HISTORY | 5 ++++ collects/redex/private/reduction-semantics.ss | 19 ++++++++++-- collects/redex/private/tl-test.ss | 23 +++++++++++++++ collects/redex/private/traces.ss | 29 ++++++++++--------- collects/redex/redex.scrbl | 10 +++++++ collects/redex/reduction-semantics.ss | 2 +- 6 files changed, 70 insertions(+), 18 deletions(-) diff --git a/collects/redex/HISTORY b/collects/redex/HISTORY index 7881397b20..1a51f5bcc3 100644 --- a/collects/redex/HISTORY +++ b/collects/redex/HISTORY @@ -1,3 +1,8 @@ + - Added tracing to metafunctions (see current-traced-metafunctions) + + - added caching-enabled? parameter (changed how set-cache-size! + works) + v4.2 - added white-bracket-sizing to control how the brackets diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 00d009ee78..c077fcf151 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -5,6 +5,7 @@ "term.ss" "loc-wrapper.ss" "error.ss" + mzlib/trace (lib "list.ss") (lib "etc.ss")) @@ -1164,14 +1165,23 @@ `(,name ,@exp) (length mtchs))] [else - (let ([ans (rhs metafunc (mtch-bindings (car mtchs)))]) + (let ([ans (rhs traced-metafunc (mtch-bindings (car mtchs)))]) (unless (match-pattern codom-compiled-pattern ans) (redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp))) (hash-set! cache exp ans) ans)])))]))] [else - cache-ref])))]) - metafunc) + cache-ref])))] + [ot (current-trace-print-args)] + [traced-metafunc (lambda (exp) + (if (or (eq? (current-traced-metafunctions) 'all) + (memq name (current-traced-metafunctions))) + (parameterize ([current-trace-print-args + (λ (name args kws kw-args level) + (ot name (car args) kws kw-args level))]) + (trace-apply name metafunc '() '() exp)) + (metafunc exp)))]) + traced-metafunc) compiled-patterns rhss) (if dom-compiled-pattern @@ -1179,6 +1189,8 @@ (λ (exp) (and (ormap (λ (pat) (match-pattern pat exp)) compiled-patterns) #t)))))) +(define current-traced-metafunctions (make-parameter '())) + (define-syntax (metafunction-form stx) (syntax-case stx () [(_ id) @@ -1788,6 +1800,7 @@ (rename-out [metafunction-form metafunction]) metafunction? metafunction-proc in-domain? + current-traced-metafunctions metafunc-proc-lang metafunc-proc-pict-info metafunc-proc-name diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index 7c0c109f48..af8919fc49 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -507,6 +507,29 @@ 'no-exn) 'no-exn)) + ;; test that tracing works properly + ;; note that caching comes into play here (which is why we don't see the recursive calls) + (let () + (define-metafunction empty-language + [(f 0) 0] + [(f number) (f ,(- (term number) 1))]) + + (let ([sp (open-output-string)]) + (parameterize ([current-output-port sp]) + (term (f 1))) + (test (get-output-string sp) "")) + + (let ([sp (open-output-string)]) + (parameterize ([current-output-port sp] + [current-traced-metafunctions 'all]) + (term (f 1))) + (test (get-output-string sp) "|(f 1)\n|0\n")) + + (let ([sp (open-output-string)]) + (parameterize ([current-output-port sp] + [current-traced-metafunctions '(f)]) + (term (f 1))) + (test (get-output-string sp) "|(f 1)\n|0\n"))) ; diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index e245c5f7d1..5efb8c074e 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -149,10 +149,12 @@ ;; only changed on the reduction thread ;; frontier : (listof (is-a?/c graph-editor-snip%)) (define frontier - (map (lambda (expr) (build-snip snip-cache #f expr pred pp - (dark-pen-color) (light-pen-color) - (dark-text-color) (light-text-color) #f)) - exprs)) + (filter + (λ (x) x) + (map (lambda (expr) (build-snip snip-cache #f expr pred pp + (dark-pen-color) (light-pen-color) + (dark-text-color) (light-text-color) #f)) + exprs))) ;; set-font-size : number -> void ;; =eventspace main thread= @@ -516,16 +518,15 @@ (define (build-snip cache parent-snip expr pred pp light-arrow-color dark-arrow-color dark-label-color light-label-color name) (let-values ([(snip new?) (let/ec k - (k - (hash-ref - cache - expr - (lambda () - (let ([new-snip (make-snip parent-snip expr pred pp)]) - (hash-set! cache expr new-snip) - (k new-snip #t)))) - #f))]) - + (values (hash-ref + cache + expr + (lambda () + (let ([new-snip (make-snip parent-snip expr pred pp)]) + (hash-set! cache expr new-snip) + (k new-snip #t)))) + #f))]) + (when parent-snip (send snip record-edge-label parent-snip name) (add-links/text-colors parent-snip snip diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 3f6b0f75e0..0335ffc8cd 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -944,6 +944,16 @@ legtimate inputs according to @scheme[metafunction-name]'s contract, and @scheme[#f] otherwise. } +@defparam[current-traced-metafunctions traced-metafunctions (or/c 'all (listof symbol?))]{ + +Controls which metafunctions are currently being traced. If it is +@scheme['all], all of them are. Otherwise, the elements of the list +name the metafunctions to trace. + +Defaults to @scheme['()]. + +} + @section{Testing} All of the exports in this section are provided both by diff --git a/collects/redex/reduction-semantics.ss b/collects/redex/reduction-semantics.ss index 7a477f2cb8..dfbd96b498 100644 --- a/collects/redex/reduction-semantics.ss +++ b/collects/redex/reduction-semantics.ss @@ -30,7 +30,6 @@ define-metafunction/extension metafunction in-domain? - caching-enabled?) (provide (rename-out [test-match redex-match]) @@ -45,6 +44,7 @@ test-results) (provide/contract + [current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))] [reduction-relation->rule-names (-> reduction-relation? (listof symbol?))] [language-nts (-> compiled-lang? (listof symbol?))] [set-cache-size! (-> number? void?)] From 2afe7621b3344758768e25e2e86426f1d0860461 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Jan 2009 16:06:37 +0000 Subject: [PATCH 43/49] PR 10010 svn: r13029 --- .../scribblings/reference/contracts.scrbl | 22 ++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 11a5cea81d..675feb7906 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -81,6 +81,13 @@ Takes any number of predicates and higher-order contracts and returns a contract that accepts any value that any one of the contracts accepts, individually. +The @scheme[or/c] result tests any value by applying the contracts in +order, from left to right, with the exception that it always moves the +non-@tech{flat contracts} (if any) to the end, checking them +last. Thus, a contract such as @scheme[(or/c (not/c real?) +positive?)] is guaranteed to only invoke the @scheme[positive?] +predicate on real numbers. + If all of the arguments are procedures or @tech{flat contracts}, the result is a @tech{flat contract}. If only one of the arguments is a higher-order contract, the result is a contract that just checks the @@ -95,11 +102,16 @@ calls @scheme[contract-first-order-passes?] with each of the higher-order contracts. If only one returns true, @scheme[or/c] uses that contract. If none of them return true, it signals a contract violation. If more than one returns true, it signals an error -indicating that the @scheme[or/c] contract is malformed. - -The @scheme[or/c] result tests any value by applying the contracts in -order, from left to right, with the exception that it always moves the -non-@tech{flat contracts} (if any) to the end, checking them last.} +indicating that multiple branches of the @scheme[or/c] each might +apply to the value. For example, this contract +@schemeblock[ +(or/c (-> number? number?) + (-> string? string? string?)) +] +cannot accept a function like this one: @scheme[(lambda args ...)] +since it cannot tell which of the two arrow contracts should be used +with the function. +} @defproc[(and/c [contract (or/c contract? (any/c . -> . any/c))] ...) contract?]{ From c9ebe9bba37b0795324cfd1f38d861f497dc6334 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Jan 2009 16:48:17 +0000 Subject: [PATCH 44/49] changed the way or/c works; PR 10010 svn: r13030 --- collects/scheme/private/contract.ss | 12 +++++++----- collects/scribblings/reference/contracts.scrbl | 8 ++++---- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index c8d3d878b8..729fe92bf2 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -966,13 +966,15 @@ improve method arity mismatch contract violation error messages? (if candidate-proc (candidate-proc val) (raise-contract-error val src-info pos-blame orig-str - "none of the branches of the or/c matched"))] + "none of the branches of the or/c matched, given ~e" + val))] [((car checks) val) (if candidate-proc - (error 'or/c "two arguments, ~s and ~s, might both match ~s" - (contract-name candidate-contract) - (contract-name (car contracts)) - val) + (raise-contract-error val src-info pos-blame orig-str + "two of the clauses in the or/c might both match: ~s and ~s, given ~e" + (contract-name candidate-contract) + (contract-name (car contracts)) + val) (loop (cdr checks) (cdr procs) (cdr contracts) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 675feb7906..1f5053a8c6 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -101,14 +101,14 @@ checks all of the @tech{flat contracts}. If none of them pass, it calls @scheme[contract-first-order-passes?] with each of the higher-order contracts. If only one returns true, @scheme[or/c] uses that contract. If none of them return true, it signals a contract -violation. If more than one returns true, it signals an error -indicating that multiple branches of the @scheme[or/c] each might -apply to the value. For example, this contract +violation. If more than one returns true, it also signals a contract +violation. +For example, this contract @schemeblock[ (or/c (-> number? number?) (-> string? string? string?)) ] -cannot accept a function like this one: @scheme[(lambda args ...)] +does not accept a function like this one: @scheme[(lambda args ...)] since it cannot tell which of the two arrow contracts should be used with the function. } From 0663588ee1f03c92ad6d4d0956a293d43e6f266d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Jan 2009 17:49:14 +0000 Subject: [PATCH 45/49] change _string/utf-16 and _string/ucs-4 so that #f = NULL (for consistency with other pointer types), and drop the /null variants svn: r13031 --- collects/mzlib/foreign.ss | 5 +- collects/scribblings/foreign/types.scrbl | 14 ++- src/foreign/foreign.c | 106 +++-------------------- src/foreign/foreign.ssc | 14 --- 4 files changed, 20 insertions(+), 119 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 87c1b45b57..34065bdbc0 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -695,9 +695,8 @@ ;; String types ;; The internal _string type uses the native ucs-4 encoding, also providing a -;; utf-16 type (note: the non-/null variants do not use #f as NULL). -(provide _string/ucs-4 _string/utf-16 - _string/ucs-4/null _string/utf-16/null) +;; utf-16 type +(provide _string/ucs-4 _string/utf-16) ;; 8-bit string encodings, #f is NULL (define ((false-or-op op) x) (and x (op x))) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index b0bac7395d..ef209def38 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -165,27 +165,25 @@ pointer. @deftogether[( @defthing[_string/ucs-4 ctype?] -@defthing[_string/ucs-4/null ctype?] )]{ A type for Scheme's native Unicode strings, which are in UCS-4 format. -These correspond to the C @cpp{mzchar*} type used by PLT Scheme. The -@schemeidfont{/null} variant treats @scheme[#f] as @cpp{NULL} and -vice-versa.} +These correspond to the C @cpp{mzchar*} type used by PLT Scheme. As usual, the types +treat @scheme[#f] as @cpp{NULL} and vice-versa.} @deftogether[( @defthing[_string/utf-16 ctype?] -@defthing[_string/utf-16/null ctype?] )]{ -Unicode strings in UTF-16 format. The @schemeidfont{/null} variant -treats @scheme[#f] as @cpp{NULL} and vice-versa.} +Unicode strings in UTF-16 format. As usual, the types treat +@scheme[#f] as @cpp{NULL} and vice-versa.} @defthing[_path ctype?]{ -Simple @cpp{char*} strings, corresponding to Scheme's paths.} +Simple @cpp{char*} strings, corresponding to Scheme's paths. As usual, +the types treat @scheme[#f] as @cpp{NULL} and vice-versa.} @defthing[_symbol ctype?]{ diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 7e312b9b3f..89dd22d2b3 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -703,16 +703,6 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_string_ucs_4 (18) /* Type Name: string/ucs-4 (string_ucs_4) - * LibFfi type: ffi_type_pointer - * C type: mzchar* - * Predicate: SCHEME_CHAR_STRINGP() - * Scheme->C: SCHEME_CHAR_STR_VAL() - * S->C offset: 0 - * C->Scheme: scheme_make_char_string_without_copying() - */ - -#define FOREIGN_string_ucs_4_null (19) -/* Type Name: string/ucs-4/null (string_ucs_4_null) * LibFfi type: ffi_type_pointer * C type: mzchar* * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() @@ -721,18 +711,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * C->Scheme: scheme_make_char_string_without_copying() */ -#define FOREIGN_string_utf_16 (20) +#define FOREIGN_string_utf_16 (19) /* Type Name: string/utf-16 (string_utf_16) - * LibFfi type: ffi_type_pointer - * C type: unsigned short* - * Predicate: SCHEME_CHAR_STRINGP() - * Scheme->C: ucs4_string_to_utf16_pointer() - * S->C offset: 0 - * C->Scheme: utf16_pointer_to_ucs4_string() - */ - -#define FOREIGN_string_utf_16_null (21) -/* Type Name: string/utf-16/null (string_utf_16_null) * LibFfi type: ffi_type_pointer * C type: unsigned short* * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() @@ -744,7 +724,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* Byte strings -- not copying C strings, #f is NULL. * (note: these are not like char* which is just a pointer) */ -#define FOREIGN_bytes (22) +#define FOREIGN_bytes (20) /* Type Name: bytes * LibFfi type: ffi_type_pointer * C type: char* @@ -754,7 +734,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * C->Scheme: (==NULL)?scheme_false:scheme_make_byte_string_without_copying() */ -#define FOREIGN_path (23) +#define FOREIGN_path (21) /* Type Name: path * LibFfi type: ffi_type_pointer * C type: char* @@ -764,7 +744,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * C->Scheme: (==NULL)?scheme_false:scheme_make_path_without_copying() */ -#define FOREIGN_symbol (24) +#define FOREIGN_symbol (22) /* Type Name: symbol * LibFfi type: ffi_type_pointer * C type: char* @@ -777,7 +757,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* This is for any C pointer: #f is NULL, cpointer values as well as * ffi-obj and string values pass their pointer. When used as a return * value, either a cpointer object or #f is returned. */ -#define FOREIGN_pointer (25) +#define FOREIGN_pointer (23) /* Type Name: pointer * LibFfi type: ffi_type_pointer * C type: void* @@ -789,7 +769,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* This is used for passing and Scheme_Object* value as is. Useful for * functions that know about Scheme_Object*s, like MzScheme's. */ -#define FOREIGN_scheme (26) +#define FOREIGN_scheme (24) /* Type Name: scheme * LibFfi type: ffi_type_pointer * C type: Scheme_Object* @@ -802,7 +782,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* Special type, not actually used for anything except to mark values * that are treated like pointers but not referenced. Used for * creating function types. */ -#define FOREIGN_fpointer (27) +#define FOREIGN_fpointer (25) /* Type Name: fpointer * LibFfi type: ffi_type_pointer * C type: void* @@ -830,9 +810,7 @@ typedef union _ForeignAny { double x_doubleS; int x_bool; mzchar* x_string_ucs_4; - mzchar* x_string_ucs_4_null; unsigned short* x_string_utf_16; - unsigned short* x_string_utf_16_null; char* x_bytes; char* x_path; char* x_symbol; @@ -842,7 +820,7 @@ typedef union _ForeignAny { } ForeignAny; /* This is a tag that is used to identify user-made struct types. */ -#define FOREIGN_struct (28) +#define FOREIGN_struct (26) /*****************************************************************************/ /* Type objects */ @@ -963,9 +941,7 @@ static int ctype_sizeof(Scheme_Object *type) case FOREIGN_doubleS: return sizeof(double); case FOREIGN_bool: return sizeof(int); case FOREIGN_string_ucs_4: return sizeof(mzchar*); - case FOREIGN_string_ucs_4_null: return sizeof(mzchar*); case FOREIGN_string_utf_16: return sizeof(unsigned short*); - case FOREIGN_string_utf_16_null: return sizeof(unsigned short*); case FOREIGN_bytes: return sizeof(char*); case FOREIGN_path: return sizeof(char*); case FOREIGN_symbol: return sizeof(char*); @@ -1242,9 +1218,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double)); case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false); case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*)); - case FOREIGN_string_ucs_4_null: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*)); case FOREIGN_string_utf_16: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*)); - case FOREIGN_string_utf_16_null: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*)); case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*)); case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*)); case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*)); @@ -1496,9 +1470,9 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, delta += (sizeof(int)-sizeof(mzchar*)); } #endif - if (SCHEME_CHAR_STRINGP(val)) { + if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) { mzchar* tmp; - tmp = (mzchar*)(SCHEME_CHAR_STR_VAL(val)); + tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val)); if (basetype_p == NULL ||tmp == NULL) { (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; @@ -1510,54 +1484,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val)); return NULL; /* hush the compiler */ } - case FOREIGN_string_ucs_4_null: -#ifdef SCHEME_BIG_ENDIAN - if (sizeof(mzchar*)C","string/ucs-4/null",0,1,&(val)); - return NULL; /* hush the compiler */ - } case FOREIGN_string_utf_16: #ifdef SCHEME_BIG_ENDIAN if (sizeof(unsigned short*)C","string/utf-16",0,1,&(val)); - return NULL; /* hush the compiler */ - } - case FOREIGN_string_utf_16_null: -#ifdef SCHEME_BIG_ENDIAN - if (sizeof(unsigned short*)C","string/utf-16/null",0,1,&(val)); + scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val)); return NULL; /* hush the compiler */ } case FOREIGN_bytes: @@ -2986,13 +2918,6 @@ void scheme_init_foreign(Scheme_Env *env) t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv); - s = scheme_intern_symbol("string/ucs-4/null"); - t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); - t->so.type = ctype_tag; - t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); - t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4_null); - scheme_add_global("_string/ucs-4/null", (Scheme_Object*)t, menv); s = scheme_intern_symbol("string/utf-16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -3000,13 +2925,6 @@ void scheme_init_foreign(Scheme_Env *env) t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv); - s = scheme_intern_symbol("string/utf-16/null"); - t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); - t->so.type = ctype_tag; - t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); - t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16_null); - scheme_add_global("_string/utf-16/null", (Scheme_Object*)t, menv); s = scheme_intern_symbol("bytes"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 37bc900f46..4a19b20652 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -653,13 +653,6 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) ) (defctype 'string/ucs-4 - 'ftype "pointer" - 'ctype "mzchar*" - 'pred "SCHEME_CHAR_STRINGP" - 's->c "SCHEME_CHAR_STR_VAL" - 'c->s "scheme_make_char_string_without_copying") - -(defctype 'string/ucs-4/null 'ftype "pointer" 'ctype "mzchar*" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" @@ -667,13 +660,6 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) 'c->s "scheme_make_char_string_without_copying") (defctype 'string/utf-16 - 'ftype "pointer" - 'ctype "unsigned short*" - 'pred "SCHEME_CHAR_STRINGP" - 's->c "ucs4_string_to_utf16_pointer" - 'c->s "utf16_pointer_to_ucs4_string") - -(defctype 'string/utf-16/null 'ftype "pointer" 'ctype "unsigned short*" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" From f6575759ba2177b08ff14a0a581568acc6a92b11 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 8 Jan 2009 01:02:38 +0000 Subject: [PATCH 46/49] macro stepper: fixed pretty-printing width svn: r13032 --- collects/macro-debugger/syntax-browser/widget.ss | 2 +- collects/macro-debugger/view/frame.ss | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 3b0a36bfa1..d202d2e6d6 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -196,7 +196,7 @@ ) display))) - (define/private (calculate-columns) + (define/public (calculate-columns) (define style (code-style -text (send config get-syntax-font-size))) (define char-width (send style get-text-width (send -ecanvas get-dc))) (define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 29688ba4f2..4cd2f150c2 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -54,6 +54,7 @@ (define/override (on-size w h) (send config set-width w) (send config set-height h) + (send config set-columns (send (send widget get-view) calculate-columns)) (send widget update/preserve-view)) (define warning-panel From cd1c0f41b38b741f300562ac6fd7021d3f1ada19 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 8 Jan 2009 01:04:13 +0000 Subject: [PATCH 47/49] stxclass: worked on opt/mand/etc error messages svn: r13033 --- .../macro-debugger/stxclass/private/kws.ss | 4 +- .../macro-debugger/stxclass/private/lib.ss | 4 +- .../macro-debugger/stxclass/private/parse.ss | 29 +++-- .../macro-debugger/stxclass/private/rep.ss | 101 +++++++++--------- .../macro-debugger/stxclass/private/sc.ss | 4 +- .../macro-debugger/stxclass/private/util.ss | 2 +- 6 files changed, 77 insertions(+), 67 deletions(-) diff --git a/collects/macro-debugger/stxclass/private/kws.ss b/collects/macro-debugger/stxclass/private/kws.ss index f81393efae..0edb3cb651 100644 --- a/collects/macro-debugger/stxclass/private/kws.ss +++ b/collects/macro-debugger/stxclass/private/kws.ss @@ -88,9 +88,9 @@ ;; A PatternParseResult is one of ;; - (listof value) -;; - (make-failed stx sexpr(Pattern) string) +;; - (make-failed stx sexpr(Pattern) string frontier/#f) (define (ok? x) (or (pair? x) (null? x))) -(define-struct failed (stx patstx reason) +(define-struct failed (stx patstx reason frontier) #:transparent) diff --git a/collects/macro-debugger/stxclass/private/lib.ss b/collects/macro-debugger/stxclass/private/lib.ss index 47e5af9f23..98f5654c4d 100644 --- a/collects/macro-debugger/stxclass/private/lib.ss +++ b/collects/macro-debugger/stxclass/private/lib.ss @@ -14,11 +14,11 @@ (define-syntax-rule (define-pred-stxclass name pred) (define-basic-syntax-class name - ([datum 0]) + () ;; ([datum 0]) (lambda (x) (let ([d (if (syntax? x) (syntax-e x) x)]) (if (pred d) - (list d) + null ;; (list d) (fail-sc x #:pattern 'name)))))) (define-pred-stxclass identifier symbol?) diff --git a/collects/macro-debugger/stxclass/private/parse.ss b/collects/macro-debugger/stxclass/private/parse.ss index dd307096ad..967678ba77 100644 --- a/collects/macro-debugger/stxclass/private/parse.ss +++ b/collects/macro-debugger/stxclass/private/parse.ss @@ -23,10 +23,12 @@ ;; - 'fail' stxparameterized to (non-escaping!) failure procedure (define-struct pk (ps k) #:transparent) -;; A FrontierContext (FC) is ({FrontierIndex stx}*) +;; A FrontierContext (FC) is one of +;; - (list FrontierIndex Syntax) +;; - (list* FrontierIndex Syntax FrontierContext) ;; A FrontierIndex is one of ;; - nat -;; - `(+ ,nat expr ...) +;; - `(+ ,nat Syntax ...) (define (empty-frontier x) (list 0 x)) @@ -59,7 +61,7 @@ (with-syntax ([(arg ...) args]) #`(lambda (x arg ...) (define (fail-rhs x expected reason frontier) - (make-failed x expected reason)) + (make-failed x expected reason frontier)) #,(parse:pks (list #'x) (list (empty-frontier #'x)) (rhs->pks rhs relsattrs #'x) @@ -72,7 +74,7 @@ (with-syntax ([k k] [x x] [p p] [reason reason] [fc-expr (frontier->expr fc)]) #`(let ([failcontext fc-expr]) - #;(printf "failing at ~s\n" failcontext) + (printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext) (k x p 'reason failcontext)))) ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) @@ -309,7 +311,7 @@ [sub-parse-expr #`(#,(ssc-parser-name ssc) #,(car vars) #,@args)]) #'sub-parse-expr)))] - [(struct pk ((cons (struct pat:gseq (orig-stx attrs depth heads tail)) + [(struct pk ((cons (and the-pattern (struct pat:gseq (orig-stx attrs depth heads tail))) rest-ps) k)) (let* ([xvar (car (generate-temporaries (list #'x)))] @@ -360,11 +362,6 @@ (if maxrep #`(< #,repvar #,maxrep) #`#t))] - [(minrepclause ...) - (for/list ([repvar reps] [minrep mins] #:when minrep) - #`[(< #,repvar #,minrep) - #,(fail #'enclosing-fail (car vars) - #:reason "minimum repetition constraint failed")])] [(occurs-binding ...) (for/list ([head heads] [rep reps] #:when (head-occurs head)) #`[#,(head-occurs head) (positive? #,rep)])] @@ -376,10 +373,20 @@ (let ([rep (add1 rep)]) (parse-loop x #,@hid-args #,@reps enclosing-fail)) #,(fail #'enclosing-fail #'var0 + #:fc (frontier:add-index (car fcs) + #'(calculate-index rep ...)) #:reason "maxiumum repetition constraint failed"))) ...]] [tail-rhs - #`(cond minrepclause ... + #`(cond #,@(for/list ([repvar reps] [minrep mins] #:when minrep) + #`[(< #,repvar #,minrep) + #,(fail #'enclosing-fail (car vars) + #:fc (frontier:add-index + (car fcs) + #'(calculate-index rep ...)) + #:pattern (expectation-of-constants + #f '(mininum-rep-constraint-failed) '()) + #:reason "minimum repetition constraint failed")]) [else (let ([hid (finalize hid-arg)] ... ... occurs-binding ... diff --git a/collects/macro-debugger/stxclass/private/rep.ss b/collects/macro-debugger/stxclass/private/rep.ss index f8ebe38114..de868a0766 100644 --- a/collects/macro-debugger/stxclass/private/rep.ss +++ b/collects/macro-debugger/stxclass/private/rep.ss @@ -347,7 +347,7 @@ (make pat:datum stx null depth (syntax->datum #'datum))] [(heads gdots . tail) (gdots? #'gdots) - (let* ([heads (parse-heads #'heads decls (add1 depth))] + (let* ([heads (parse-heads #'heads decls depth)] [tail (parse-pattern #'tail decls depth)] [hattrs (append-attrs (for/list ([head heads]) (head-attrs head)) stx)] [tattrs (pattern-attrs tail)]) @@ -372,40 +372,6 @@ [(struct pattern (orig-stx iattrs depth)) (make head orig-stx iattrs depth (list p) #f #f #t #f #f)])) -(define (parse-heads stx decls depth) - (syntax-case stx () - [({} . more) - (raise-syntax-error 'pattern "empty head sequence not allowed" (stx-car stx))] - [({p ...} . more) - (let* ([heads - (for/list ([p (syntax->list #'(p ...))]) - (parse-pattern p decls depth))] - [heads-attrs - (append-attrs (map pattern-attrs heads) (stx-car stx))]) - (parse-heads-k #'more - heads - heads-attrs - depth - (lambda (more min max as-list? occurs-pvar default) - (let ([occurs-attrs - (if occurs-pvar - (list (make-attr occurs-pvar depth null)) - null)]) - (cons (make head (stx-car stx) - (append-attrs (list occurs-attrs heads-attrs) - (stx-car stx)) - depth - heads - min max as-list? - occurs-pvar - default) - (parse-heads more decls depth))))))] - [() - null] - [_ - (raise-syntax-error 'pattern "expected sequence of patterns or sequence directive" - (if (pair? stx) (car stx) stx))])) - (define head-directive-table (list (list '#:min check-nat/f) (list '#:max check-nat/f) @@ -414,9 +380,24 @@ (list '#:opt) (list '#:mand))) -(define (parse-heads-k stx heads heads-attrs heads-depth k) - (define-values (chunks rest) (chunk-kw-seq/no-dups stx head-directive-table)) - (reject-duplicate-chunks chunks) +(define (parse-heads stx decls enclosing-depth) + (syntax-case stx () + [({} . more) + (raise-syntax-error 'pattern "empty head sequence not allowed" (stx-car stx))] + [({p ...} . more) + (let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)]) + (reject-duplicate-chunks chunks) ;; FIXME: needed? + (cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks) + (parse-heads rest decls enclosing-depth)))] + [() + null] + [_ + (raise-syntax-error 'pattern "expected sequence of patterns or sequence directive" + (cond [(pair? stx) (car stx)] + [(syntax? stx) stx] + [else #f]))])) + +(define (parse-head/chunks pstx decls enclosing-depth chunks) (let* ([min-row (assq '#:min chunks)] [max-row (assq '#:max chunks)] [occurs-row (assq '#:occurs chunks)] @@ -443,20 +424,42 @@ (unless opt-row (raise-syntax-error #f "default only allowed for optional patterns" - (cadr default-row))) - (unless (and (pair? head-attrs) - (null? (cdr head-attrs)) - (= heads-depth (attr-depth (car head-attrs))) - (null? (attr-inner (car head-attrs)))) + (cadr default-row)))) + (parse-head/options pstx + decls + enclosing-depth + (cond [opt-row 0] [mand-row 1] [else min]) + (cond [opt-row 1] [mand-row 1] [else max]) + (not (or opt-row mand-row)) + (and occurs-row (caddr occurs-row)) + default-row))) + +(define (parse-head/options pstx decls enclosing-depth + min max as-list? occurs-pvar default-row) + (let* ([depth (if as-list? (add1 enclosing-depth) enclosing-depth)] + [heads + (for/list ([p (syntax->list pstx)]) + (parse-pattern p decls depth))] + [heads-attrs + (append-attrs (map pattern-attrs heads) pstx)]) + (when default-row + (unless (and (= (length heads-attrs) 1) + (= enclosing-depth (attr-depth (car heads-attrs))) + (null? (attr-inner (car heads-attrs)))) (raise-syntax-error #f "default only allowed for patterns with single simple pattern variable" (cadr default-row)))) - (k rest - (cond [opt-row 0] [mand-row 1] [else min]) - (cond [opt-row 1] [mand-row 1] [else max]) - (not (or opt-row mand-row)) - (and occurs-row (caddr occurs-row)) - (and default-row (caddr default-row))))) + (let ([occurs-attrs + (if occurs-pvar + (list (make-attr occurs-pvar depth null)) + null)]) + (make head pstx + (append-attrs (list occurs-attrs heads-attrs) pstx) + depth + heads + min max as-list? + occurs-pvar + (and default-row (caddr default-row)))))) ;; append-attrs : (listof (listof IAttr)) stx -> (listof IAttr) (define (append-attrs attrss stx) diff --git a/collects/macro-debugger/stxclass/private/sc.ss b/collects/macro-debugger/stxclass/private/sc.ss index dc13171f49..bbd192aa76 100644 --- a/collects/macro-debugger/stxclass/private/sc.ss +++ b/collects/macro-debugger/stxclass/private/sc.ss @@ -214,7 +214,7 @@ (frontier->syntax rest)])) (define (fail-sc stx #:pattern [pattern #f] #:reason [reason #f]) - (make-failed stx pattern reason)) + (make-failed stx pattern reason #f)) (define (syntax-class-fail stx #:reason [reason #f]) - (make-failed stx #f reason)) + (make-failed stx #f reason #f)) diff --git a/collects/macro-debugger/stxclass/private/util.ss b/collects/macro-debugger/stxclass/private/util.ss index af88bb003c..efa24ed302 100644 --- a/collects/macro-debugger/stxclass/private/util.ss +++ b/collects/macro-debugger/stxclass/private/util.ss @@ -86,7 +86,7 @@ (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))] [(kw . more) (keyword? (syntax-e #'kw)) - (raise-syntax-error #f "unexpected keyword" #'kw ctx)] + (raise-syntax-error #f "unexpected keyword" ctx #'kw)] [_ (values (reverse rchunks) stx)])) (loop stx null)) From 5027415305ab089245b2e6534c3504d6a9b52afa Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 8 Jan 2009 08:50:13 +0000 Subject: [PATCH 48/49] Welcome to a new PLT day. svn: r13034 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c637c6f355..c487735d3b 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "7jan2009") +#lang scheme/base (provide stamp) (define stamp "8jan2009") From df5e59561f69818119af38c9217b554f253fbf76 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 8 Jan 2009 14:46:46 +0000 Subject: [PATCH 49/49] 1. Reorganized so that generating an `any' doesn't require reprocessing the language definition. 2. Turned optional arguments to check-metafunction, generate-term, etc. into keywords. 3. Added #:source keyword to `check' form. svn: r13035 --- collects/redex/private/rg-test.ss | 265 +++++++++++++++------- collects/redex/private/rg.ss | 364 ++++++++++++++++++------------ 2 files changed, 404 insertions(+), 225 deletions(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index b556163db9..a46e922206 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -155,6 +155,12 @@ (define next-any-decision (decision any)) (define next-sequence-decision (decision seq))))) +(define-syntax generate-term/decisions + (syntax-rules () + [(_ lang pat size attempt decisions) + (parameterize ([generation-decisions decisions]) + (generate-term lang pat size #:attempt attempt))])) + (let () (define-language lc (e (e e) x (λ (x) e)) @@ -162,7 +168,7 @@ ;; Generate (λ (x) x) (test - (generate-term + (generate-term/decisions lc e 1 0 (decisions #:var (list (λ _ 'x) (λ _'x)) #:nt (patterns third first first first))) @@ -170,14 +176,14 @@ ;; Generate pattern that's not a non-terminal (test - (generate-term + (generate-term/decisions lc (x x x_1 x_1) 1 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)))) '(x x y y)) ; After choosing (e e), size decremented forces each e to x. (test - (generate-term + (generate-term/decisions lc e 1 0 (decisions #:nt (patterns first) #:var (list (λ _ 'x) (λ _ 'y)))) @@ -193,7 +199,9 @@ (let* ([x null] [prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))]) (test (begin - (generate-term lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!))) + (generate-term/decisions + lang a 5 0 + (decisions #:var (list (λ _ 'x) prepend! prepend!))) x) '(x x)))) @@ -204,7 +212,7 @@ (x (variable-except λ))) (test (exn:fail-message - (generate-term + (generate-term/decisions postfix e 2 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)) #:nt (patterns third second first first)))) @@ -215,7 +223,7 @@ (define-language var (e (variable-except x y))) (test - (generate-term + (generate-term/decisions var e 2 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z)))) 'z)) @@ -232,26 +240,28 @@ (n number) (z 4)) (test - (generate-term + (generate-term/decisions lang a 2 0 (decisions #:num (build-list 3 (λ (n) (λ (_) n))) #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 1)))) `(0 1 2 "foo" "foo" "foo" "bar" #t)) - (test (generate-term lang b 5 0 (decisions #:seq (list (λ (_) 0)))) + (test (generate-term/decisions lang b 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate-term lang c 5 0 (decisions #:seq (list (λ (_) 0)))) + (test (generate-term/decisions lang c 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate-term lang d 5 0 (decisions #:seq (list (λ (_) 2)))) + (test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2)))) '(4 4 4 4 (4 4) (4 4))) (test (exn:fail-message (generate-term lang e 5)) #rx"generate: unable to generate pattern e") - (test (generate-term lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) - (test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 - (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) - (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3)))) + (test (generate-term/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) + (test (generate-term/decisions + lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 + (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) + (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3)))) '((0 0 0) (0 0 0 0) (1 1 1))) - (test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 - (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5)))) + (test (generate-term/decisions + lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 + (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5)))) '((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1)))) (let () @@ -264,7 +274,7 @@ ;; x and y bound in body (test (let/ec k - (generate-term + (generate-term/decisions lc e 10 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))) #:nt (patterns first first first third first) @@ -274,7 +284,7 @@ (let () (define-language lang (e (variable-prefix pf))) (test - (generate-term + (generate-term/decisions lang e 5 0 (decisions #:var (list (λ _ 'x)))) 'pfx)) @@ -288,7 +298,7 @@ (define-language lang (e number (e_1 e_2 e e_1 e_2))) (test - (generate-term + (generate-term/decisions lang e 5 0 (decisions #:nt (patterns second first first first) #:num (list (λ _ 2) (λ _ 3) (λ _ 4)))) @@ -300,7 +310,7 @@ (x variable)) (test (let/ec k - (generate-term + (generate-term/decisions lang e 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) '(x))) @@ -311,12 +321,12 @@ (b (c_!_1 c_!_1 c_!_1)) (c 1 2)) (test - (generate-term + (generate-term/decisions lang a 5 0 (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) '(1 1 2)) (test - (generate-term + (generate-term/decisions lang (number_!_1 number_!_2 number_!_1) 5 0 (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) '(1 1 2)) @@ -330,7 +340,7 @@ (f foo bar)) (test (let/ec k - (generate-term + (generate-term/decisions lang e 5 0 (decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?)))))))) (cons '(#\a #\b #\f #\o #\r) @@ -350,24 +360,26 @@ #rx"unable to generate") (test ; binding works for with side-conditions failure/retry (let/ec k - (generate-term + (generate-term/decisions lang d 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))))) '(y)) (test ; mismatch patterns work with side-condition failure/retry - (generate-term + (generate-term/decisions lang e 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y)))) '(y x y)) (test ; generate compiles side-conditions in pattern - (generate-term lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0 - (decisions #:var (list (λ _ 'x) (λ _ 'y)))) + (generate-term/decisions + lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0 + (decisions #:var (list (λ _ 'x) (λ _ 'y)))) 'y) (test ; bindings within ellipses collected properly (let/ec k - (generate-term lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0 - (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4)) - #:num (build-list 7 (λ (n) (λ (_) n)))))) + (generate-term/decisions + lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0 + (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4)) + #:num (build-list 7 (λ (n) (λ (_) n)))))) '((0 1 2) (3 4 5 6)))) (let () @@ -397,7 +409,7 @@ (y variable)) (test - (generate-term + (generate-term/decisions lang (in-hole A number ) 5 0 (decisions #:nt (patterns second second first first third first second first first) @@ -406,19 +418,22 @@ (test (generate-term lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5)) (test (generate-term lang (hole 4) 5) (term (hole 4))) - (test (generate-term lang (variable_1 (in-hole C variable_1)) 5 0 - (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x)))) + (test (generate-term/decisions + lang (variable_1 (in-hole C variable_1)) 5 0 + (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x)))) '(x x)) - (test (generate-term lang (variable_!_1 (in-hole C variable_!_1)) 5 0 - (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y)))) + (test (generate-term/decisions + lang (variable_!_1 (in-hole C variable_!_1)) 5 0 + (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y)))) '(x y)) - (test (let/ec k (generate-term lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) + (test (let/ec k + (generate-term/decisions lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) '(x)) - (test (generate-term lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) + (test (generate-term/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) '((2 (1 1)) 1)) - (test (generate-term lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) + (test (generate-term/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) '(1 0)) - (test (generate-term lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) + (test (generate-term/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) '((2 ((3 (2 1)) 3)) 1))) (let () @@ -426,7 +441,7 @@ (e (e e) (+ e e) x v) (v (λ (x) e) number) (x variable-not-otherwise-mentioned)) - (test (generate-term lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x)))) + (test (generate-term/decisions lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x)))) 'x)) (let () @@ -436,19 +451,24 @@ (define-language empty) ;; `any' pattern - (test (call-with-values (λ () (pick-any four (make-random 0 1))) list) - (list four 'f)) - (test (call-with-values (λ () (pick-any four (make-random 1))) list) - (list sexp 'sexp)) - (test (generate-term four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4) - (test (generate-term four any 5 0 - (decisions #:any (list (λ _ (values sexp 'sexp))) - #:nt (patterns fifth second second second) - #:seq (list (λ _ 3)) - #:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz")))) + (let ([four (prepare-lang four)] + [sexp (prepare-lang sexp)]) + (test (call-with-values (λ () (pick-any four sexp (make-random 0 1))) list) + (list four 'f)) + (test (call-with-values (λ () (pick-any four sexp (make-random 1))) list) + (list sexp 'sexp))) + (test (generate-term/decisions + four any 5 0 (decisions #:any (list (λ (lang sexp) (values lang 'e))))) 4) + (test (generate-term/decisions + four any 5 0 + (decisions #:any (list (λ (lang sexp) (values sexp 'sexp))) + #:nt (patterns fifth second second second) + #:seq (list (λ _ 3)) + #:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz")))) '("foo" "bar" "baz")) - (test (generate-term empty any 5 0 (decisions #:nt (patterns first) - #:var (list (λ _ 'x)))) + (test (generate-term/decisions + empty any 5 0 (decisions #:nt (patterns first) + #:var (list (λ _ 'x)))) 'x)) ;; `hide-hole' pattern @@ -469,15 +489,16 @@ (e x (e e) v) (v (λ (x) e)) (x variable-not-otherwise-mentioned)) - (test (generate-term lang (cross e) 3 0 - (decisions #:nt (patterns fourth first first second first first first) - #:var (list (λ _ 'x) (λ _ 'y)))) + (test (generate-term/decisions + lang (cross e) 3 0 + (decisions #:nt (patterns fourth first first second first first first) + #:var (list (λ _ 'x) (λ _ 'y)))) (term (λ (x) (hole y))))) -;; current-error-port-output : (-> (-> any) string) -(define (current-error-port-output thunk) +;; current-output : (-> (-> any) string) +(define (current-output thunk) (let ([p (open-output-string)]) - (parameterize ([current-error-port p]) + (parameterize ([current-output-port p]) (thunk)) (begin0 (get-output-string p) @@ -487,16 +508,78 @@ (let () (define-language lang (d 5) - (e e 4)) - (test (current-error-port-output (λ () (check lang d 2 #f))) - "failed after 1 attempts:\n5\n") + (e e 4) + (n number)) + (test (current-output (λ () (check lang d #f))) + "counterexample found after 1 attempts:\n5\n") (test (check lang d #t) #t) - (test (check lang (d e) 2 (and (eq? (term d) 5) (eq? (term e) 4))) #t) - (test (check lang (d ...) 2 (zero? (modulo (foldl + 0 (term (d ...))) 5))) #t) - (test (current-error-port-output (λ () (check lang (d e) 2 #f))) - "failed after 1 attempts:\n(5 4)\n") - (test (current-error-port-output (λ () (check lang d 2 (error 'pred-raised)))) - "failed after 1 attempts:\n5\n")) + (test (check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t) + (test (check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t) + (test (current-output (λ () (check lang (d e) #f))) + "counterexample found after 1 attempts:\n(5 4)\n") + (test (current-output (λ () (check lang d (error 'pred-raised)))) + "counterexample found after 1 attempts:\n5\n") + (test (parameterize ([check-randomness (make-random 0 0)]) + (check lang n (eq? 42 (term n)) + #:attempts 1 + #:source (reduction-relation lang (--> 42 x)))) + #t) + (test (current-output + (λ () + (parameterize ([check-randomness (make-random 0 0)]) + (check lang n (eq? 42 (term n)) + #:attempts 1 + #:source (reduction-relation lang (--> 0 x z)))))) + "counterexample found (z) after 1 attempts:\n0\n") + (test (current-output + (λ () + (parameterize ([check-randomness (make-random 1)]) + (check lang d (eq? 42 (term n)) + #:attempts 1 + #:source (reduction-relation lang (--> 0 x z)))))) + "counterexample found after 1 attempts:\n5\n") + (test (let ([r (reduction-relation lang (--> 0 x z))]) + (check lang n (number? (term n)) + #:attempts 10 + #:source r)) + #t) + (let () + (define-metafunction lang + [(mf 0) 0] + [(mf 42) 0]) + (test (parameterize ([check-randomness (make-random 0 1)]) + (check lang (n) (eq? 42 (term n)) + #:attempts 1 + #:source mf)) + #t)) + (let () + (define-language L) + (test (with-handlers ([exn:fail? exn-message]) + (check lang any #t #:source (reduction-relation L (--> 1 1)))) + #rx"language for secondary source")) + (let () + (test (with-handlers ([exn:fail? exn-message]) + (check lang n #t #:source (reduction-relation lang (--> x 1)))) + #rx"x does not match n")) + + (let ([stx-err (λ (stx) + (with-handlers ([exn:fail:syntax? exn-message]) + (expand stx) + 'no-syntax-error))]) + (parameterize ([current-namespace (make-base-namespace)]) + (eval '(require "../reduction-semantics.ss" + "rg.ss")) + (eval '(define-language empty)) + (test (stx-err '(check empty any #t #:typo 3)) + #rx"check: bad keyword syntax") + (test (stx-err '(check empty any #t #:attempts 3 #:attempts 4)) + #rx"bad keyword syntax") + (test (stx-err '(check empty any #t #:attempts)) + #rx"bad keyword syntax") + (test (stx-err '(check empty any #t #:attempts 3 4)) + #rx"bad keyword syntax") + (test (stx-err '(check empty any #t #:source #:attempts)) + #rx"bad keyword syntax")))) ;; check-metafunction-contract (let () @@ -518,22 +601,31 @@ [(i any ...) (any ...)]) ;; Dom(f) < Ctc(f) - (test (current-error-port-output - (λ () (check-metafunction-contract f (decisions #:num (list (λ _ 2) (λ _ 5)))))) - "failed after 1 attempts:\n(5)\n") + (test (current-output + (λ () + (parameterize ([generation-decisions + (decisions #:num (list (λ _ 2) (λ _ 5)))]) + (check-metafunction-contract f)))) + "counterexample found after 1 attempts:\n(5)\n") ;; Rng(f) > Codom(f) - (test (current-error-port-output - (λ () (check-metafunction-contract f (decisions #:num (list (λ _ 3)))))) - "failed after 1 attempts:\n(3)\n") + (test (current-output + (λ () + (parameterize ([generation-decisions + (decisions #:num (list (λ _ 3)))]) + (check-metafunction-contract f)))) + "counterexample found after 1 attempts:\n(3)\n") ;; LHS matches multiple ways - (test (current-error-port-output - (λ () (check-metafunction-contract g (decisions #:num (list (λ _ 1) (λ _ 1)) - #:seq (list (λ _ 2)))))) - "failed after 1 attempts:\n(1 1)\n") + (test (current-output + (λ () + (parameterize ([generation-decisions + (decisions #:num (list (λ _ 1) (λ _ 1)) + #:seq (list (λ _ 2)))]) + (check-metafunction-contract g)))) + "counterexample found after 1 attempts:\n(1 1)\n") ;; OK -- generated from Dom(h) (test (check-metafunction-contract h) #t) ;; OK -- generated from pattern (any ...) - (test (check-metafunction-contract i) #t)) + (test (check-metafunction-contract i #:attempts 5) #t)) ;; check-reduction-relation (let () @@ -562,12 +654,12 @@ (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))]) (test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t) - (test (current-error-port-output + (test (current-output (λ () (check-reduction-relation S (λ (x) #f)))) - "checking name failed after 1 attempts:\n1\n") - (test (current-error-port-output + "counterexample found after 1 attempts with name:\n1\n") + (test (current-output (λ () (check-reduction-relation S (curry eq? 1)))) - "checking unnamed failed after 1 attempts:\n3\n")) + "counterexample found after 1 attempts with unnamed:\n3\n")) (let ([T (reduction-relation L @@ -593,11 +685,14 @@ [(m 2) whatever]) (let ([generated null]) (test (begin - (check-metafunction m (λ (t) (set! generated (cons t generated))) 1) + (check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1) generated) (reverse '((1) (2))))) - (test (current-error-port-output (λ () (check-metafunction m (curry eq? 1)))) - #rx"checking clause #1 failed after 1 attempt")) + (test (current-output (λ () (check-metafunction m (curry eq? 1)))) + #rx"counterexample found after 1 attempts with clause #1") + (test (with-handlers ([exn:fail:contract? exn-message]) + (check-metafunction m #t #:attempts 'NaN)) + #rx"check-metafunction: expected")) ;; parse/unparse-pattern (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 834700ce45..6174f0ac82 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -76,10 +76,12 @@ To do a better job of not generating programs with free variables, (pick-from-list lang-lits random) (list->string (build-list length (λ (_) (pick-char attempt lang-chars random)))))) -(define (pick-any lang [random random]) - (if (and (not (null? (compiled-lang-lang lang))) (zero? (random 5))) - (values lang (pick-from-list (map nt-name (compiled-lang-lang lang)) random)) - (values sexp (nt-name (car (compiled-lang-lang sexp)))))) +(define (pick-any lang sexp [random random]) + (let ([c-lang (rg-lang-clang lang)] + [c-sexp (rg-lang-clang sexp)]) + (if (and (not (null? (compiled-lang-lang c-lang))) (zero? (random 5))) + (values lang (pick-from-list (map nt-name (compiled-lang-lang c-lang)) random)) + (values sexp (nt-name (car (compiled-lang-lang c-sexp))))))) (define (pick-string lang-chars lang-lits attempt [random random]) (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random)) @@ -153,21 +155,24 @@ To do a better job of not generating programs with free variables, (define (pick-sequence-length attempt) (random-natural (expected-value->p (attempt->size attempt)))) +(define (zip . lists) + (apply (curry map list) lists)) + (define (min-prods nt base-table) (let* ([sizes (hash-ref base-table (nt-name nt))] - [min-size (apply min/f sizes)] - [zip (λ (l m) (map cons l m))]) - (map cdr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt)))))) + [min-size (apply min/f sizes)]) + (map cadr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt)))))) + +(define-struct rg-lang (clang lits chars base-table)) +(define (prepare-lang lang) + (let ([lits (map symbol->string (compiled-lang-literals lang))]) + (make-rg-lang (parse-language lang) lits (unique-chars lits) (find-base-cases lang)))) (define (generate lang decisions@) (define-values/invoke-unit decisions@ (import) (export decisions^)) - (define lang-lits (map symbol->string (compiled-lang-literals lang))) - (define lang-chars (unique-chars lang-lits)) - (define base-table (find-base-cases lang)) - - (define (generate-nt name fvt-id bound-vars size attempt in-hole state) + (define ((generate-nt lang generate base-table) name fvt-id bound-vars size attempt in-hole state) (let*-values ([(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)] [(term _) @@ -178,8 +183,9 @@ To do a better job of not generating programs with free variables, (if (zero? size) (min-prods (nt-by-name lang name) base-table) ((next-non-terminal-decision) name lang bound-vars attempt)))]) - (((generate-pat bound-vars (max 0 (sub1 size)) attempt) (rhs-pattern rhs) in-hole) - (make-state (map fvt-entry (rhs-var-info rhs)) #hash())))) + (generate bound-vars (max 0 (sub1 size)) attempt + (make-state (map fvt-entry (rhs-var-info rhs)) #hash()) + in-hole (rhs-pattern rhs)))) (λ (_ env) (mismatches-satisfied? env)))]) (values term (extend-found-vars fvt-id term state)))) @@ -202,8 +208,7 @@ To do a better job of not generating programs with free variables, (if (null? envs) (values null null fvt) (let*-values - ([(term state) ((generate (ellipsis-pattern ellipsis) the-hole) - (make-state fvt (car envs)))] + ([(term state) (generate (make-state fvt (car envs)) the-hole (ellipsis-pattern ellipsis))] [(terms envs fvt) (recur (state-fvt state) (cdr envs))]) (values (cons term terms) (cons (state-env state) envs) fvt))))]) (values seq (make-state fvt (merge-environments envs))))) @@ -241,6 +246,7 @@ To do a better job of not generating programs with free variables, (hash-set! prior val #t))))))) (define-struct state (fvt env)) + (define new-state (make-state null #hash())) (define (set-env state name value) (make-state (state-fvt state) (hash-set (state-env state) name value))) @@ -255,9 +261,12 @@ To do a better job of not generating programs with free variables, (define (fvt-entry binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f)) - (define (((generate-pat bound-vars size attempt) pat in-hole) state) - (define recur (generate-pat bound-vars size attempt)) - (define (recur/pat pat) ((recur pat in-hole) state)) + (define (generate-pat lang sexp bound-vars size attempt state in-hole pat) + (define recur (curry generate-pat lang sexp bound-vars size attempt)) + (define recur/pat (recur state in-hole)) + + (define clang (rg-lang-clang lang)) + (define gen-nt (generate-nt clang (curry generate-pat lang sexp) (rg-lang-base-table lang))) (match pat [`number (values ((next-number-decision) attempt) state)] @@ -265,17 +274,22 @@ To do a better job of not generating programs with free variables, (generate/pred 'variable (λ () (recur/pat 'variable)) (λ (var _) (not (memq var vars))))] - [`variable (values ((next-variable-decision) lang-chars lang-lits bound-vars attempt) state)] + [`variable + (values ((next-variable-decision) + (rg-lang-chars lang) (rg-lang-lits lang) bound-vars attempt) + state)] [`variable-not-otherwise-mentioned (generate/pred 'variable (λ () (recur/pat 'variable)) - (λ (var _) (not (memq var (compiled-lang-literals lang)))))] + (λ (var _) (not (memq var (compiled-lang-literals clang)))))] [`(variable-prefix ,prefix) (define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) (let-values ([(term state) (recur/pat 'variable)]) (values (symbol-append prefix term) state))] - [`string (values ((next-string-decision) lang-chars lang-lits attempt) state)] + [`string + (values ((next-string-decision) (rg-lang-chars lang) (rg-lang-lits lang) attempt) + state)] [`(side-condition ,pat ,(? procedure? condition)) (generate/pred (unparse-pattern pat) (λ () (recur/pat pat)) @@ -286,38 +300,38 @@ To do a better job of not generating programs with free variables, [`hole (values in-hole state)] [`(in-hole ,context ,contractum) (let-values ([(term state) (recur/pat contractum)]) - ((recur context term) state))] - [`(hide-hole ,pattern) ((recur pattern the-hole) state)] + (recur state term context))] + [`(hide-hole ,pattern) (recur state the-hole pattern)] [`any - (let*-values ([(lang nt) ((next-any-decision) lang)] - [(term _) (((generate lang decisions@) nt) size attempt)]) + (let*-values ([(lang nt) ((next-any-decision) lang sexp)] + [(term _) (generate-pat lang sexp null size attempt new-state the-hole nt)]) (values term state))] - [(? (is-nt? lang)) - (generate-nt pat pat bound-vars size attempt in-hole state)] - [(struct binder ((and name (or (? (is-nt? lang) nt) (app (symbol-match named-nt-rx) (? (is-nt? lang) nt)))))) - (generate/prior pat state (λ () (generate-nt nt name bound-vars size attempt in-hole state)))] + [(? (is-nt? clang)) + (gen-nt pat pat bound-vars size attempt in-hole state)] + [(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))) + (generate/prior pat state (λ () (gen-nt nt name bound-vars size attempt in-hole state)))] [(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b))))) (generate/prior pat state (λ () (recur/pat b)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? lang) nt))))) - (let-values ([(term state) (generate-nt nt pat bound-vars size attempt in-hole state)]) + [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt))))) + (let-values ([(term state) (gen-nt nt pat bound-vars size attempt in-hole state)]) (values term (set-env state pat term)))] [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b))))) (let-values ([(term state) (recur/pat b)]) (values term (set-env state pat term)))] [`(cross ,(? symbol? cross-nt)) - (generate-nt cross-nt #f bound-vars size attempt in-hole state)] + (gen-nt cross-nt #f bound-vars size attempt in-hole state)] [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)] [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) (let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)]) (if prior prior ((next-sequence-decision) attempt)))] [(seq state) (generate-sequence ellipsis recur state length)] - [(rest state) ((recur rest in-hole) - (set-env (set-env state class length) name length))]) + [(rest state) (recur (set-env (set-env state class length) name length) + in-hole rest)]) (values (append seq rest) state))] [(list-rest pat rest) (let*-values ([(pat-term state) (recur/pat pat)] - [(rest-term state) ((recur rest in-hole) state)]) + [(rest-term state) (recur state in-hole rest)]) (values (cons pat-term rest-term) state))] [else (error 'generate "unknown pattern ~s\n" pat)])) @@ -356,17 +370,19 @@ To do a better job of not generating programs with free variables, (state-fvt state)) (state-env state))) - (λ (pat) - (let ([unparsed (unparse-pattern pat)]) - (λ (size attempt) - (let-values ([(term state) - (generate/pred - unparsed - (λ () - (((generate-pat null size attempt) pat the-hole) - (make-state null #hash()))) - (λ (_ env) (mismatches-satisfied? env)))]) - (values term (bindings (state-env state)))))))) + (let ([rg-lang (prepare-lang lang)] + [rg-sexp (prepare-lang sexp)]) + (λ (pat) + (let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))]) + (λ (size attempt) + (let-values ([(term state) + (generate/pred + pat + (λ () + (generate-pat rg-lang rg-sexp null size attempt + new-state the-hole parsed)) + (λ (_ env) (mismatches-satisfied? env)))]) + (values term (bindings (state-env state))))))))) ;; find-base-cases : compiled-language -> hash-table (define (find-base-cases lang) @@ -604,133 +620,198 @@ To do a better job of not generating programs with free variables, [_ pat])))) ;; used in generating the `any' pattern -(define sexp - (let () - (define-language sexp (sexp variable string number hole (sexp ...))) - (parse-language sexp))) +(define-language sexp (sexp variable string number hole (sexp ...))) + +(define-for-syntax (metafunc name) + (let ([tf (syntax-local-value name (λ () #f))]) + (and (term-fn? tf) (term-fn-get-id tf)))) + +(define-for-syntax (metafunc/err name stx) + (let ([m (metafunc name)]) + (if m m (raise-syntax-error #f "not a metafunction" stx name)))) + +(define (assert-nat name x) + (unless (and (integer? x) (>= x 0)) + (raise-type-error name "natural number" x))) + +(define-for-syntax (term-generator lang pat decisions what) + (with-syntax ([pattern + (rewrite-side-conditions/check-errs + (language-id-nts lang what) + what #t pat)] + [lang lang] + [decisions decisions]) + (syntax ((generate lang (decisions lang)) `pattern)))) + +(define-syntax (generate-term stx) + (syntax-case stx () + [(_ lang pat size #:attempt attempt) + (with-syntax ([generate (term-generator #'lang #'pat #'(generation-decisions) 'generate-term)]) + (syntax/loc stx + (let-values ([(term _) (generate size attempt)]) + term)))] + [(_ lang pat size) + (syntax/loc stx (generate-term lang pat size #:attempt 1))])) + +(define check-randomness (make-parameter random)) (define-syntax (check stx) (syntax-case stx () - [(_ lang pat property) - (syntax/loc stx (check lang pat default-check-attempts property))] - [(_ lang pat attempts property) + [(_ lang pat property . kw-args) (let-values ([(names names/ellipses) - (extract-names (language-id-nts #'lang 'generate) 'check #t #'pat)]) + (extract-names (language-id-nts #'lang 'check) 'check #t #'pat)] + [(attempts-stx source-stx) + (let loop ([args (syntax kw-args)] + [attempts #f] + [source #f]) + (syntax-case args () + [() (values attempts source)] + [(#:attempts a . rest) + (not (or attempts (keyword? (syntax-e #'a)))) + (loop #'rest #'a source)] + [(#:source s . rest) + (not (or source (keyword? (syntax-e #'s)))) + (loop #'rest attempts #'s)] + [else (raise-syntax-error #f "bad keyword syntax" stx args)]))]) (with-syntax ([(name ...) names] - [(name/ellipses ...) names/ellipses]) - (syntax/loc stx - (or (check-property - (term-generator lang pat random-decisions) - (λ (_ bindings) - (with-handlers ([exn:fail? (λ (_) #f)]) + [(name/ellipses ...) names/ellipses] + [attempts (or attempts-stx #'default-check-attempts)]) + (quasisyntax/loc stx + (let ([att attempts]) + (assert-nat 'check att) + (or (check-property + (cons (list #,(term-generator #'lang #'pat #'random-decisions 'check) #f) + (let ([lang-gen (generate lang (random-decisions lang))]) + #,(if (not source-stx) + #'null + #`(let-values + ([(pats srcs src-lang) + #,(cond [(and (identifier? source-stx) (metafunc source-stx)) + => + (λ (m) #`(values (metafunc-proc-lhs-pats #,m) + (metafunc-srcs #,m) + (metafunc-proc-lang #,m)))] + [else + #`(let ([r #,source-stx]) + (unless (reduction-relation? r) + (raise-type-error 'check "reduction-relation" r)) + (values + (map rewrite-proc-lhs (reduction-relation-make-procs r)) + (reduction-relation-srcs r) + (reduction-relation-lang r)))])]) + (unless (eq? src-lang lang) + (error 'check "language for secondary source must match primary pattern's language")) + (zip (map lang-gen pats) srcs))))) + #,(and source-stx #'(test-match lang pat)) + (λ (generated) (error 'check "~s does not match ~s" generated 'pat)) + (λ (_ bindings) (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) - property))) - attempts) - (void)))))])) + property)) + att + (λ (term attempt source port) + (fprintf port "counterexample found~aafter ~a attempts:\n" + (if source (format " (~a) " source) " ") attempt) + (pretty-print term port)) + (check-randomness)) + (void))))))])) -(define (check-property generate property attempts [source #f]) +(define (check-property gens-srcs match match-fail property attempts display [random random]) (let loop ([remaining attempts]) (if (zero? remaining) #t (let ([attempt (add1 (- attempts remaining))]) - (let-values ([(term bindings) - (generate (attempt->size attempt) attempt)]) - (if (property term bindings) + (let*-values ([(generator source) + (apply values + (if (and (not (null? (cdr gens-srcs))) (zero? (random 10))) + (pick-from-list (cdr gens-srcs) random) + (car gens-srcs)))] + [(term bindings) + (generator (attempt->size attempt) attempt)]) + (if (andmap (λ (bindings) + (with-handlers ([exn:fail? (λ (_) #f)]) + (property term bindings))) + (cond [(and match (match term)) + => (curry map (compose make-bindings match-bindings))] + [match (match-fail term)] + [else (list bindings)])) (loop (sub1 remaining)) (begin - (when source - (fprintf (current-error-port) "checking ~a " source)) - (fprintf (current-error-port) "failed after ~s attempts:\n" attempt) - (pretty-print term (current-error-port)) + (display term attempt source (current-output-port)) #f))))))) -(define-syntax generate-term - (syntax-rules () - [(_ lang pat size attempt decisions) - (let-values ([(term _) ((term-generator lang pat decisions) size attempt)]) - term)] - [(_ lang pat size attempt) - (generate-term lang pat size attempt random-decisions)] - [(_ lang pat size) - (generate-term lang pat size 1)])) - -(define-syntax (term-generator stx) - (syntax-case stx () - [(_ lang pat decisions) - (with-syntax ([pattern - (rewrite-side-conditions/check-errs - (language-id-nts #'lang 'generate) - 'generate #t #'pat)]) - (syntax/loc stx - (let ([lang (parse-language lang)]) - ((generate lang (decisions lang)) - (reassign-classes (parse-pattern `pattern lang 'top-level))))))])) - -(define-for-syntax (metafunc name stx) - (let ([tf (syntax-local-value name (λ () #f))]) - (if (term-fn? tf) - (term-fn-get-id tf) - (raise-syntax-error #f "not a metafunction" stx name)))) - (define-syntax (check-metafunction-contract stx) (syntax-case stx () - [(_ name) - (syntax/loc stx (check-metafunction-contract name random-decisions))] - [(_ name decisions) + [(_ name) + (syntax/loc stx + (check-metafunction-contract name #:attempts default-check-attempts))] + [(_ name #:attempts attempts) (identifier? #'name) - (with-syntax ([m (metafunc #'name stx)]) + (with-syntax ([m (metafunc/err #'name stx)]) (syntax/loc stx - (let ([lang (parse-language (metafunc-proc-lang m))] - [dom (metafunc-proc-dom-pat m)]) + (let ([lang (metafunc-proc-lang m)] + [dom (metafunc-proc-dom-pat m)] + [decisions (generation-decisions)] + [att attempts]) + (assert-nat 'check-metafunction-contract att) (check-property - ((generate lang (decisions lang)) - (reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level))) - (λ (t _) - (with-handlers ([exn:fail:redex? (λ (_) #f)]) - (begin (term (name ,@t)) #t))) - default-check-attempts))))])) + (list (list ((generate lang (decisions lang)) (if dom dom '(any (... ...)))) #f)) + #f + #f + (λ (t _) (begin (term (name ,@t)) #t)) + att + (λ (term attempt _ port) + (fprintf port "counterexample found after ~a attempts:\n" attempt) + (pretty-print term port))))))])) -(define (check-property-many lang patterns ids prop decisions attempts) - (let* ([lang-gen (generate lang (decisions lang))] - [pat-gens (map (λ (pat) (lang-gen (reassign-classes (parse-pattern pat lang 'top-level)))) - patterns)]) - (for/and ([pat patterns] - [id ids]) +(define (check-property-many lang pats srcs prop decisions attempts) + (let ([lang-gen (generate lang (decisions lang))]) + (for/and ([pat pats] [src srcs]) (check-property - (let ([gen (lang-gen (reassign-classes (parse-pattern pat lang 'top-level)))]) - (λ (size attempt) (gen size attempt))) + (let ([gen (lang-gen pat)]) + (list (list (λ (size attempt) (gen size attempt)) src))) + #f + #f (λ (term _) (prop term)) attempts - id)))) + (λ (term attempt source port) + (fprintf port "counterexample found after ~a attempts with ~a:\n" + attempt source) + (pretty-print term port)))))) + +(define (metafunc-srcs m) + (build-list (length (metafunc-proc-lhs-pats m)) + (compose (curry format "clause #~s") add1))) (define-syntax (check-metafunction stx) (syntax-case stx () [(_ name property) - (syntax/loc stx (check-metafunction name property default-check-attempts))] - [(_ name property attempts) - (syntax/loc stx (check-metafunction name property random-decisions attempts))] - [(_ name property decisions attempts) - (with-syntax ([m (metafunc #'name stx)]) + (syntax/loc stx (check-metafunction name property #:attempts default-check-attempts))] + [(_ name property #:attempts attempts) + (with-syntax ([m (metafunc/err #'name stx)]) (syntax/loc stx - (or (check-property-many - (parse-language (metafunc-proc-lang m)) - (metafunc-proc-lhs-pats m) - (build-list (length (metafunc-proc-lhs-pats m)) - (compose (curry format "clause #~s") add1)) - property - decisions - attempts) - (void))))])) + (let ([att attempts]) + (assert-nat 'check-metafunction att) + (or (check-property-many + (metafunc-proc-lang m) + (metafunc-proc-lhs-pats m) + (metafunc-srcs m) + property + (generation-decisions) + att) + (void)))))])) + +(define (reduction-relation-srcs r) + (map (λ (proc) (or (rewrite-proc-name proc) 'unnamed)) + (reduction-relation-make-procs r))) (define (check-reduction-relation relation property #:decisions [decisions random-decisions] #:attempts [attempts default-check-attempts]) (or (check-property-many - (parse-language (reduction-relation-lang relation)) + (reduction-relation-lang relation) (map rewrite-proc-lhs (reduction-relation-make-procs relation)) - (map (λ (proc) (or (rewrite-proc-name proc) 'unnamed)) - (reduction-relation-make-procs relation)) + (reduction-relation-srcs relation) property decisions attempts) @@ -758,14 +839,17 @@ To do a better job of not generating programs with free variables, (define (next-any-decision) pick-any) (define (next-string-decision) pick-string))) +(define generation-decisions (make-parameter random-decisions)) + (provide pick-from-list pick-var min-prods decisions^ pick-sequence-length is-nt? pick-char random-string pick-string check nt-by-name pick-nt unique-chars pick-any sexp generate-term parse-pattern class-reassignments reassign-classes unparse-pattern (struct-out ellipsis) (struct-out mismatch) (struct-out class) - (struct-out binder) check-metafunction-contract + (struct-out binder) check-metafunction-contract prepare-lang pick-number parse-language check-reduction-relation - preferred-production-threshold check-metafunction) + preferred-production-threshold check-metafunction check-randomness + generation-decisions) (provide/contract [find-base-cases (-> compiled-lang? hash?)]) \ No newline at end of file