From a51ea08cb42e2db9f38427d1a12d4c675293abd6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 9 Oct 2008 01:33:35 +0000 Subject: [PATCH 01/14] fix a bug, when there is no user field svn: r11982 --- collects/handin-server/status-web-root/servlets/status.ss | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index db3a9cdd48..352f151049 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/collects/handin-server/status-web-root/servlets/status.ss @@ -225,8 +225,10 @@ (tr (td ([colspan "2"] [align "center"]) (input ([type "submit"] [name "post"] [value "Login"])))))))))] - [user (clean-str (aget (request-bindings request) 'user))] - [passwd (aget (request-bindings request) 'passwd)] + [bindings (request-bindings request)] + [user (aget bindings 'user)] + [passwd (aget bindings 'passwd)] + [user (and user (clean-str user))] [user-data (get-user-data user)]) (cond [(and user-data (string? passwd) From 18f05a6823c423f0a0e2b042ac524699b9cc557b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 9 Oct 2008 07:50:08 +0000 Subject: [PATCH 02/14] Welcome to a new PLT day. svn: r11983 --- 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 d878f05a88..82572f2e46 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "8oct2008") +#lang scheme/base (provide stamp) (define stamp "9oct2008") From b2ce9f4cd3a3ed2e18773656229612a44d308b0d Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 9 Oct 2008 19:09:11 +0000 Subject: [PATCH 03/14] 1. Fixed bug in reduction-semantics.ss. 2. Fixed bug in generation of 'any pattern. 3. Added `check-metafunction' form. svn: r11984 --- collects/redex/private/reduction-semantics.ss | 11 ++- collects/redex/private/rg-test.ss | 60 ++++++++++--- collects/redex/private/rg.ss | 86 +++++++++++++------ 3 files changed, 119 insertions(+), 38 deletions(-) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 39ef1d1a55..b57539df09 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -758,7 +758,7 @@ (symbol->string (bind-name y)))))) (define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!) - (make-struct-type 'metafunc-proc #f 8 0 #f null (current-inspector) 0)) + (make-struct-type 'metafunc-proc #f 9 0 #f null (current-inspector) 0)) (define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 1)) (define metafunc-proc-lang (make-struct-field-accessor metafunc-proc-ref 2)) (define metafunc-proc-multi-arg? (make-struct-field-accessor metafunc-proc-ref 3)) @@ -766,6 +766,7 @@ (define metafunc-proc-cps (make-struct-field-accessor metafunc-proc-ref 5)) (define metafunc-proc-rhss (make-struct-field-accessor metafunc-proc-ref 6)) (define metafunc-proc-in-dom? (make-struct-field-accessor metafunc-proc-ref 7)) +(define metafunc-proc-dom-pat (make-struct-field-accessor metafunc-proc-ref 8)) (define-struct metafunction (proc)) (define-syntax (in-domain? stx) @@ -865,14 +866,14 @@ (and dom-ctcs (rewrite-side-conditions/check-errs lang-nts - #t 'define-metafunction + #f dom-ctcs))] [codom-side-conditions-rewritten (rewrite-side-conditions/check-errs lang-nts - #t 'define-metafunction + #f codom-contract)] [(rhs-fns ...) (map (λ (lhs rhs bindings) @@ -935,7 +936,8 @@ 'name cps rhss - (let ([name (lambda (x) (name-predicate x))]) name))) + (let ([name (lambda (x) (name-predicate x))]) name) + `dom-side-conditions-rewritten)) `dom-side-conditions-rewritten `codom-side-conditions-rewritten 'name)) @@ -1711,6 +1713,7 @@ metafunc-proc-cps metafunc-proc-rhss metafunc-proc-in-dom? + metafunc-proc-dom-pat (struct-out binds)) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index d6bca72153..d36b9036cf 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -414,6 +414,7 @@ (define-language four (e 4) (f 5)) + (define-language empty) ;; `any' pattern (test (call-with-values (λ () (pick-any four (make-random (list 0 1)))) list) @@ -426,7 +427,10 @@ #:nt (patterns fifth second second second) #:seq (list (λ _ 3)) #:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz")))) - '("foo" "bar" "baz"))) + '("foo" "bar" "baz")) + (test (generate/decisions empty any 5 0 (decisions #:nt (patterns first) + #:var (list (λ _ 'x)))) + 'x)) ;; `hide-hole' pattern (let () @@ -460,19 +464,55 @@ (get-output-string p) (close-output-port p)))) +;; check (let () (define-language lang (d 5) (e e 4)) - (test (current-error-port-output (λ () (check lang d 2 0 #f))) - "failed after 1 attempts: 5") - (test (check lang d 2 0 #t) #t) - (test (check lang (d e) 2 0 (and (eq? (term d) 5) (eq? (term e) 4))) #t) - (test (check lang (d ...) 2 0 (zero? (modulo (foldl + 0 (term (d ...))) 5))) #t) - (test (current-error-port-output (λ () (check lang (d e) 2 0 #f))) - "failed after 1 attempts: (5 4)") - (test (exn:fail-message (check lang d 2 0 (error 'pred-raised))) - #rx"term 5 raises")) + (test (current-error-port-output (λ () (check lang d 2 #f))) + "failed 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")) + +;; check-metafunction +;; TODO: handle no metafunctions with no contract +(let () + (define-language empty) + (define-metafunction empty + f : (side-condition number_1 (odd? (term number_1))) -> number + [(f 1) 1] + [(f 3) 'NaN]) + + (define-metafunction empty + g : number ... -> (any ...) + [(g number_1 ... 1 number_2 ...) ()]) + + (define-metafunction empty + h : number -> number + [(h any) any]) + + (define-metafunction empty + [(i any ...) (any ...)]) + + ;; Dom(f) < Ctc(f) + (test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 2) (λ _ 5)))))) + "failed after 1 attempts:\n(5)\n") + ;; Rng(f) > Codom(f) + (test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 3)))))) + "failed after 1 attempts:\n(3)\n") + ;; LHS matches multiple ways + (test (current-error-port-output (λ () (check-metafunction g (decisions #:num (list (λ _ 1) (λ _ 1)) + #:seq (list (λ _ 2)))))) + "failed after 1 attempts:\n(1 1)\n") + ;; OK -- generated from Dom(h) + (test (check-metafunction h) #t) + ;; OK -- generated from pattern 'any + (test (check-metafunction i) #t)) ;; 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 3ce57de2e6..1b994a9f6b 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -21,7 +21,10 @@ To do a better job of not generating programs with free variables, "reduction-semantics.ss" "underscore-allowed.ss" "term.ss" + "error.ss" (for-syntax "rewrite-side-conditions.ss") + (for-syntax "term-fn.ss") + (for-syntax "reduction-semantics.ss") mrlib/tex-table) (define random-numbers '(0 1 -1 17 8)) @@ -39,6 +42,10 @@ To do a better job of not generating programs with free variables, (hash-map uniq (λ (k v) k)))) (define generation-retries 100) + +(define default-check-attempts 100) +(define check-growth-base 5) + (define ascii-chars-threshold 50) (define tex-chars-threshold 500) (define chinese-chars-threshold 2000) @@ -89,7 +96,7 @@ To do a better job of not generating programs with free variables, (list->string (build-list length (λ (_) (pick-char attempt lang-chars random)))))) (define (pick-any lang [random random]) - (if (zero? (random 5)) + (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)))))) @@ -114,7 +121,7 @@ To do a better job of not generating programs with free variables, (error 'generate "unable to generate pattern ~s in ~s attempts" (unparse-pattern pat) generation-retries)) -(define (generate* lang pat size [decisions@ random-decisions@]) +(define (generate* lang pat [decisions@ random-decisions@]) (define-values/invoke-unit decisions@ (import) (export decisions^)) @@ -240,7 +247,7 @@ To do a better job of not generating programs with free variables, [`(hide-hole ,pattern) ((recur pattern the-hole) state)] [`any (let*-values ([(lang nt) ((next-any-decision) lang)] - [(term _) ((generate* lang nt size decisions@) attempt)]) + [(term _) ((generate* lang nt decisions@) size attempt)]) (values term state))] [(? (is-nt? lang)) (generate-nt pat pat bound-vars size attempt in-hole state)] @@ -306,7 +313,7 @@ To do a better job of not generating programs with free variables, (state-fvt state)) (state-env state))) - (λ (attempt) + (λ (size attempt) (let-values ([(term state) (generate/pred pat @@ -554,43 +561,53 @@ To do a better job of not generating programs with free variables, (define-syntax (check stx) (syntax-case stx () - [(_ lang pat attempts size property) + [(_ lang pat property) + (syntax/loc stx (check lang pat default-check-attempts property))] + [(_ lang pat attempts property) (let-values ([(names names/ellipses) (extract-names (language-id-nts #'lang 'generate) 'check #t #'pat)]) (with-syntax ([(name ...) names] [(name/ellipses ...) names/ellipses]) (syntax/loc stx - (let ([generator (term-generator lang pat size random-decisions@)]) - (let loop ([remaining attempts]) - (if (zero? remaining) - #t - (let ([attempt (add1 (- attempts remaining))]) - (let-values ([(term bindings) (generator attempt)]) - (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) - (if (with-handlers - ([exn:fail? (λ (exn) (error 'check "term ~s raises ~s" term exn))]) - property) - (loop (sub1 remaining)) - (fprintf (current-error-port) - "failed after ~s attempts: ~s" - attempt term)))))))))))])) + (check-property + (term-generator lang pat random-decisions@) + (λ (_ bindings) + (with-handlers ([exn:fail? (λ (_) #f)]) + (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) + property))) + attempts))))])) + +(define (check-property generate property attempts) + (let loop ([remaining attempts]) + (if (zero? remaining) + #t + (let ([attempt (add1 (- attempts remaining))]) + (let-values ([(term bindings) + (generate (floor (/ (log attempt) (log check-growth-base))) attempt)]) + (if (property term bindings) + (loop (sub1 remaining)) + (begin + (fprintf (current-error-port) + "failed after ~s attempts:\n" + attempt) + (pretty-print term (current-error-port))))))))) (define-syntax generate (syntax-rules () [(_ lang pat size attempt) - (let-values ([(term _) ((term-generator lang pat size random-decisions@) attempt)]) + (let-values ([(term _) ((term-generator lang pat random-decisions@) size attempt)]) term)] [(_ lang pat size) (generate lang pat size 0)])) (define-syntax generate/decisions (syntax-rules () [(_ lang pat size attempt decisions@) - (let-values ([(term _) ((term-generator lang pat size decisions@) attempt)]) + (let-values ([(term _) ((term-generator lang pat decisions@) size attempt)]) term)])) (define-syntax (term-generator stx) (syntax-case stx () - [(_ lang pat size decisions@) + [(_ lang pat decisions@) (with-syntax ([pattern (rewrite-side-conditions/check-errs (language-id-nts #'lang 'generate) @@ -599,7 +616,28 @@ To do a better job of not generating programs with free variables, (generate* (parse-language lang) (reassign-classes (parse-pattern `pattern lang 'top-level)) - size decisions@)))])) + decisions@)))])) + +(define-syntax (check-metafunction stx) + (syntax-case stx () + [(_ name) (syntax/loc stx (check-metafunction name random-decisions@))] + [(_ name decisions@) + (identifier? #'name) + (with-syntax ([m (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)))]) + (syntax + (let ([lang (metafunc-proc-lang m)] + [dom (metafunc-proc-dom-pat m)]) + (check-property + (generate* (parse-language lang) + (reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level)) + decisions@) + (λ (t _) + (with-handlers ([exn:fail:redex? (λ (_) #f)]) + (begin (term (name ,@t)) #t))) + 100))))])) (define-signature decisions^ (next-variable-decision @@ -623,7 +661,7 @@ To do a better job of not generating programs with free variables, pick-nt unique-chars pick-any sexp generate parse-pattern class-reassignments reassign-classes unparse-pattern (struct-out ellipsis) (struct-out mismatch) (struct-out class) - (struct-out binder) generate/decisions) + (struct-out binder) generate/decisions check-metafunction) (provide/contract [find-base-cases (-> compiled-lang? hash?)]) \ No newline at end of file From 31c55616a9475866e09b6e9f87986683569940ff Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 10 Oct 2008 07:50:11 +0000 Subject: [PATCH 04/14] Welcome to a new PLT day. svn: r11985 --- 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 82572f2e46..58b805f12e 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "9oct2008") +#lang scheme/base (provide stamp) (define stamp "10oct2008") From 4f57cbbf3716108df7907d4e2aed39bfd827e7fa Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 10 Oct 2008 09:58:18 +0000 Subject: [PATCH 05/14] fix flushing issue svn: r11986 --- collects/scribblings/guide/io.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/guide/io.scrbl b/collects/scribblings/guide/io.scrbl index 478d197811..a81dda3be9 100644 --- a/collects/scribblings/guide/io.scrbl +++ b/collects/scribblings/guide/io.scrbl @@ -114,9 +114,9 @@ with the output port; when the function returns, the port is closed. (begin (define-values (s-in c-out) (make-pipe)) (define-values (c-in s-out) (make-pipe)))) (display "hello\n" c-out) - (read-line s-in) (close-output-port c-out) (read-line s-in) + (read-line s-in) ]} @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - From 14c4931da37211241e8322e8a08bea83b9c68df6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 11 Oct 2008 07:50:11 +0000 Subject: [PATCH 06/14] Welcome to a new PLT day. svn: r11987 --- 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 58b805f12e..fee8a5bce5 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "10oct2008") +#lang scheme/base (provide stamp) (define stamp "11oct2008") From 489f4b623c00721dcad5ca7ba91c8ccd92656433 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Oct 2008 12:47:28 +0000 Subject: [PATCH 07/14] remove bogus -lpthread from 3m link (slipped in with places change) svn: r11988 --- src/mzscheme/gc2/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index 6c3ccb8321..fd08b1cc0f 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -21,7 +21,7 @@ RANLIB = @RANLIB@ CPPFLAGS = @PREFLAGS@ @OPTIONS@ @GC2OPTIONS@ @MZOPTIONS@ -I$(builddir)/.. -I$(srcdir)/../include CFLAGS = @CFLAGS@ $(CPPFLAGS) @COMPFLAGS@ @PROFFLAGS@ -LIBS = @LIBS@ -lpthread +LIBS = @LIBS@ DEF_COLLECTS_DIR = +D INITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../../collects; pwd`"'"' From 95fa65b7b3cb06cf4c8daf40d92f61783fec4f77 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Oct 2008 14:50:22 +0000 Subject: [PATCH 08/14] fix great awlful memory leak in scribble's collect phase (which was exposed most clearly by the web-server tutorial); change in.sxref to be use fasl (bytecode) format svn: r11989 --- collects/scribble/manual.ss | 19 +++---- collects/setup/scribble.ss | 100 ++++++++++++++++++------------------ 2 files changed, 59 insertions(+), 60 deletions(-) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 2d34bea913..e4af7d94eb 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -376,19 +376,16 @@ (hash-ref checkers lib (lambda () - (let ([ns (make-base-empty-namespace)]) - (parameterize ([current-namespace ns]) - (namespace-require `(for-label ,lib))) + (let ([ns-id + (let ([ns (make-base-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require `(for-label ,lib)) + (namespace-syntax-introduce (datum->syntax #f 'x))))]) (let ([checker (lambda (id) - (parameterize ([current-namespace - ns]) - (free-label-identifier=? - (namespace-syntax-introduce - (datum->syntax - #f - (syntax-e id))) - id)))]) + (free-label-identifier=? + (datum->syntax ns-id (syntax-e id)) + id))]) (hash-set! checkers lib checker) checker))))]) (and (checker id) lib))) diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index 8b15b4ccb6..5bf6258ec3 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -330,12 +330,9 @@ (for-each (lambda (k) (hash-set! ht k #t)) keys) ht)) -(define (read-out-sxref) +(define (read-sxref) (fasl->s-exp (current-input-port))) -(define (normalized-read) - (with-module-reading-parameterization read)) - (define (make-sci-cached sci info-out-file setup-printf) (when (verbose) (fprintf (current-error-port) " [Lazy ~a]\n" info-out-file)) @@ -348,7 +345,7 @@ (void) #; (fprintf (current-error-port) " [Re-load ~a]\n" info-out-file)) - (let ([v (cadr (with-input-from-file info-out-file read-out-sxref))]) + (let ([v (cadr (with-input-from-file info-out-file read-sxref))]) (set! b (make-weak-box v)) v))))))) @@ -360,7 +357,6 @@ doc) (let* ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "out.sxref")] [info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "in.sxref")] - [out-file (build-path (doc-dest-dir doc) "index.html")] [src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))]) (build-path base "compiled" (path-add-suffix name ".zo")))] [renderer (make-renderer latex-dest doc)] @@ -378,9 +374,9 @@ (build-path (collection-path "scribble") "scribble.css") #f (lambda () +inf.0)))] - [my-time (file-or-directory-modify-seconds out-file #f (lambda () -inf.0))] [info-out-time (file-or-directory-modify-seconds info-out-file #f (lambda () #f))] [info-in-time (file-or-directory-modify-seconds info-in-file #f (lambda () #f))] + [my-time (min (or info-out-time -inf.0) (or info-in-time -inf.0))] [vers (send renderer get-serialize-version)] [up-to-date? (and info-out-time @@ -402,46 +398,48 @@ (path->name (doc-src-file doc))) (if up-to-date? ;; Load previously calculated info: - (with-handlers ([exn:fail? (lambda (exn) - (fprintf (current-error-port) "~a\n" (exn-message exn)) - (delete-file info-out-file) - (delete-file info-in-file) - ((get-doc-info only-dirs latex-dest auto-main? - auto-user? with-record-error - setup-printf) - doc))]) - (let* ([v-in (with-input-from-file info-in-file normalized-read)] - [v-out (with-input-from-file info-out-file read-out-sxref)]) - (unless (and (equal? (car v-in) (list vers (doc-flags doc))) - (equal? (car v-out) (list vers (doc-flags doc)))) - (error "old info has wrong version or flags")) - (make-info - doc - (make-sci-cached - (list-ref v-out 1) ; sci (leave serialized) - info-out-file - setup-printf) - (let ([v (list-ref v-out 2)]) ; provides - (with-my-namespace - (lambda () - (deserialize v)))) - (let ([v (list-ref v-in 1)]) ; undef - (with-my-namespace - (lambda () - (deserialize v)))) - (let ([v (list-ref v-in 3)]) ; searches - (with-my-namespace - (lambda () - (deserialize v)))) - (map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build... - null ; known deps (none at this point) - can-run? - my-time info-out-time - (and can-run? (memq 'always-run (doc-flags doc))) - #f #f - vers - #f - #f))) + (render-time + "use" + (with-handlers ([exn:fail? (lambda (exn) + (fprintf (current-error-port) "~a\n" (exn-message exn)) + (delete-file info-out-file) + (delete-file info-in-file) + ((get-doc-info only-dirs latex-dest auto-main? + auto-user? with-record-error + setup-printf) + doc))]) + (let* ([v-in (with-input-from-file info-in-file read-sxref)] + [v-out (with-input-from-file info-out-file read-sxref)]) + (unless (and (equal? (car v-in) (list vers (doc-flags doc))) + (equal? (car v-out) (list vers (doc-flags doc)))) + (error "old info has wrong version or flags")) + (make-info + doc + (make-sci-cached + (list-ref v-out 1) ; sci (leave serialized) + info-out-file + setup-printf) + (let ([v (list-ref v-out 2)]) ; provides + (with-my-namespace + (lambda () + (deserialize v)))) + (let ([v (list-ref v-in 1)]) ; undef + (with-my-namespace + (lambda () + (deserialize v)))) + (let ([v (list-ref v-in 3)]) ; searches + (with-my-namespace + (lambda () + (deserialize v)))) + (map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build... + null ; known deps (none at this point) + can-run? + my-time info-out-time + (and can-run? (memq 'always-run (doc-flags doc))) + #f #f + vers + #f + #f)))) (if can-run? ;; Run the doc once: (with-record-error @@ -456,7 +454,7 @@ [ri (send renderer resolve (list v) (list dest-dir) ci)] [out-v (and info-out-time (with-handlers ([exn:fail? (lambda (exn) #f)]) - (let ([v (with-input-from-file info-out-file read-out-sxref)]) + (let ([v (with-input-from-file info-out-file read-sxref)]) (unless (equal? (car v) (list vers (doc-flags doc))) (error "old info has wrong version or flags")) v)))] @@ -497,6 +495,10 @@ (unless latex-dest (render-time "xref-out" (write-out info setup-printf))) (set-info-need-out-write?! info #f)) + (when (info-need-in-write? info) + (unless latex-dest + (render-time "xref-in" (write-in info))) + (set-info-need-in-write?! info #f)) info)))) (lambda () #f)) #f)))) @@ -644,7 +646,7 @@ setup-printf))) (define (write-in info) (make-directory* (doc-dest-dir (info-doc info))) - (write- info "in.sxref" (lambda (o i) (write (i))))) + (write- info "in.sxref" (lambda (o i) (write-bytes (s-exp->fasl (i)))))) (define (rel->path r) (if (bytes? r) From 161f9301f42a3ae5df0c47ef845698cd2e009e0e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 11 Oct 2008 18:17:20 +0000 Subject: [PATCH 09/14] clicking in the whitespace between circles no longer counts as your turn svn: r11990 --- collects/games/chat-noir/chat-noir.ss | 46 ++++++++++++++++++++------- 1 file changed, 34 insertions(+), 12 deletions(-) diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss index 9f40276a1d..7439dc5555 100644 --- a/collects/games/chat-noir/chat-noir.ss +++ b/collects/games/chat-noir/chat-noir.ss @@ -1,6 +1,6 @@ #| -Hint: include the size of the board in your world structure +hint: include the size of the board in your world structure This enables you to make test cases with different size boards, making some of the test cases much easier to manage. @@ -624,11 +624,15 @@ making some of the test cases much easier to manage. [(equal? evt 'button-up) (cond [(equal? 'playing (world-state world)) - (move-cat - (make-world (add-obstacle (world-board world) x y) - (world-cat world) - (world-state world) - (world-size world)))] + (cond + [(point-in-circle? (world-board world) x y) + (move-cat + (make-world (add-obstacle (world-board world) x y) + (world-cat world) + (world-state world) + (world-size world)))] + [else + world])] [else world])] [else @@ -833,6 +837,29 @@ making some of the test cases much easier to manage. (list (make-cell (make-posn 0 0) true) (make-cell (make-posn 0 1) false))) +;; point-in-circle? : board number number -> boolean +(define (point-in-circle? board x y) + (cond + [(empty? board) false] + [else + (local [(define cell (first board)) + (define center (+ (cell-center-x (cell-p cell)) + (* (sqrt -1) (cell-center-y (cell-p cell))))) + (define p (+ x (* (sqrt -1) y)))] + (or (<= (magnitude (- center p)) circle-radius) + (point-in-circle? (rest board) x y)))])) +(check-expect (point-in-circle? empty 0 0) false) +(check-expect (point-in-circle? (list (make-cell (make-posn 0 0) false)) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + true) +(check-expect (point-in-circle? (list (make-cell (make-posn 0 0) false)) + 0 0) + false) + + + + ; ; @@ -997,12 +1024,7 @@ making some of the test cases much easier to manage. 'playing board-size))] - (and - - ;; illustrates the speedup for state-based dfs - ;((lambda (x) true) (time (build-table initial-world))) - ;((lambda (x) true) (time (build-table/fast initial-world))) - + (and ;((lambda (x) true) (time (build-table initial-world))) ;((lambda (x) true) (time (build-table/fast initial-world))) (big-bang (world-width board-size) (world-height board-size) 1 From cff6f07259c2fc2656c6e27aa07c19d5cf5331fe Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 11 Oct 2008 19:09:50 +0000 Subject: [PATCH 10/14] fix whitespace before open-brace issues svn: r11991 --- collects/teachpack/htdp/scribblings/world.scrbl | 8 ++++---- collects/typed-scheme/typed-scheme.scrbl | 11 ++++++----- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/collects/teachpack/htdp/scribblings/world.scrbl b/collects/teachpack/htdp/scribblings/world.scrbl index a0f6584c97..f31a6d9557 100644 --- a/collects/teachpack/htdp/scribblings/world.scrbl +++ b/collects/teachpack/htdp/scribblings/world.scrbl @@ -47,13 +47,13 @@ pinholes are at position @scheme[(0,0)]. @defproc[(empty-scene [width natural-number/c] [height natural-number/c]) - (unsyntax @tech{Scene})] -{Creates a @scheme[width] x @scheme[height] @tech{Scene}.} + (unsyntax @tech{Scene})]{ + Creates a @scheme[width] x @scheme[height] @tech{Scene}.} @defproc[(place-image [img image?] [x number?] [y number?] [s (unsyntax @tech{Scene})]) - (unsyntax @tech{Scene})] -{Creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s]; + (unsyntax @tech{Scene})]{ + Creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s]; @scheme[(x,y)] are comp. graph. coordinates, i.e., they count right and down from the upper-left corner.} diff --git a/collects/typed-scheme/typed-scheme.scrbl b/collects/typed-scheme/typed-scheme.scrbl index 70161835d7..4c7a66e389 100644 --- a/collects/typed-scheme/typed-scheme.scrbl +++ b/collects/typed-scheme/typed-scheme.scrbl @@ -522,11 +522,12 @@ types. In most cases, use of @scheme[:] is preferred to use of @scheme[define:] (define-struct: name ([f : t] ...)) (define-struct: (name parent) ([f : t] ...)) (define-struct: (v ...) name ([f : t] ...)) -(define-struct: (v ...) (name parent) ([f : t] ...))]] -{Defines a @rtech{structure} with the name @scheme[name], where the fields - @scheme[f] have types @scheme[t]. The second and fourth forms define @scheme[name] - to be a substructure of @scheme[parent]. The last two forms define structures that - are polymorphic in the type variables @scheme[v].} +(define-struct: (v ...) (name parent) ([f : t] ...))]]{ + Defines a @rtech{structure} with the name @scheme[name], where the + fields @scheme[f] have types @scheme[t]. The second and fourth forms + define @scheme[name] to be a substructure of @scheme[parent]. The + last two forms define structures that are polymorphic in the type + variables @scheme[v].} @subsection{Type Aliases} @defform*[[(define-type-alias name t) From 078ce5f8c6dc17d41c45b9686c5333a0383b0915 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 11 Oct 2008 19:17:17 +0000 Subject: [PATCH 11/14] removed unused leftover file svn: r11992 --- .../typed-scheme/unit-tests/infer-tests.ss | 1 - collects/typed-scheme/utils/tables.ss | 31 ------------------- 2 files changed, 32 deletions(-) delete mode 100644 collects/typed-scheme/utils/tables.ss diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index bf3b7b95ec..f792b1efb7 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -3,7 +3,6 @@ (require (rep type-rep) (r:infer infer) (private type-effect-convenience union type-utils) - (prefix-in table: (utils tables)) (schemeunit)) diff --git a/collects/typed-scheme/utils/tables.ss b/collects/typed-scheme/utils/tables.ss deleted file mode 100644 index 08b94a026a..0000000000 --- a/collects/typed-scheme/utils/tables.ss +++ /dev/null @@ -1,31 +0,0 @@ -#lang scheme/base - -(provide (all-defined-out)) - -;; alist->eq : alist -> table -(define (alist->eq l) - (for/hasheq ([e l]) - (values (car e) (cdr e)))) - -(define (sexp->eq l) - (for/hasheq ([e l]) - (values (car e) (cadr e)))) - -;; to-sexp : table -> Listof(List k v) -(define (to-sexp t) (hash-map t list)) - -;; union/value : table(k,v) table(k,v) [(v v -> v)] -> table(k,v) -(define (union/value t1 t2 [f (lambda (x y) x)]) - (for/fold ([new-table t1]) - ([(k v) t2]) - (cond [(hash-ref new-table k #f) - => - (lambda (v*) (hash-set new-table k (f v* v)))] - [else - (hash-set new-table k v)]))) - -(define (make-eq) (make-immutable-hasheq null)) - -(define (lookup k t) (hash-ref t k #f)) - -(define (insert k v t) (hash-set t k v)) From b46a5091ba096e318106bfc609d4f7c62dcc3a00 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Oct 2008 01:49:42 +0000 Subject: [PATCH 12/14] fix change that avoids re-running documents just to get xref information when the .sxref files are up-to-date svn: r11993 --- collects/setup/scribble.ss | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index 5bf6258ec3..518a7975cf 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -357,6 +357,7 @@ doc) (let* ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "out.sxref")] [info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "in.sxref")] + [out-file (build-path (doc-dest-dir doc) "index.html")] [src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))]) (build-path base "compiled" (path-add-suffix name ".zo")))] [renderer (make-renderer latex-dest doc)] @@ -374,17 +375,24 @@ (build-path (collection-path "scribble") "scribble.css") #f (lambda () +inf.0)))] + [my-time (file-or-directory-modify-seconds out-file #f (lambda () -inf.0))] [info-out-time (file-or-directory-modify-seconds info-out-file #f (lambda () #f))] [info-in-time (file-or-directory-modify-seconds info-in-file #f (lambda () #f))] - [my-time (min (or info-out-time -inf.0) (or info-in-time -inf.0))] + [info-time (min (or info-out-time -inf.0) (or info-in-time -inf.0))] [vers (send renderer get-serialize-version)] + [src-time (max aux-time + (file-or-directory-modify-seconds + src-zo #f (lambda () +inf.0)))] [up-to-date? (and info-out-time info-in-time (or (not can-run?) - (my-time . >= . (max aux-time - (file-or-directory-modify-seconds - src-zo #f (lambda () +inf.0))))))] + ;; Need to rebuild if output file is older than input: + (my-time . >= . src-time) + ;; But we can use in/out information if they're already built; + ;; this is mostly useful if we interrupt setup-plt after + ;; it runs some documents without rendering them: + (info-time . >= . src-time)))] [can-run? (and (or (not latex-dest) (not (omit? (doc-category doc)))) (or can-run? From 2bd0019110f83b31d50a075d4bb30e9339299b02 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 12 Oct 2008 06:13:46 +0000 Subject: [PATCH 13/14] register-finalizer is not unsafe svn: r11994 --- collects/mzlib/foreign.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index be4163e98b..c034b4b748 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1567,8 +1567,7 @@ (define killer-executor (make-will-executor)) (define killer-thread #f) -(provide* (unsafe register-finalizer)) -(define (register-finalizer obj finalizer) +(define* (register-finalizer obj finalizer) (unless killer-thread (set! killer-thread (thread (lambda () From e1c4040072d65ce60912bfd9fd736d1daf46fca7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 12 Oct 2008 07:50:11 +0000 Subject: [PATCH 14/14] Welcome to a new PLT day. svn: r11995 --- 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 fee8a5bce5..754b0f0b38 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "11oct2008") +#lang scheme/base (provide stamp) (define stamp "12oct2008")