From 3619b5b2d83a3c549c10edc157585528a0ff9f8c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 25 May 2010 15:42:11 -0600 Subject: [PATCH 01/52] Fixing typo --- collects/meta/drdr/config.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/drdr/config.ss b/collects/meta/drdr/config.ss index ab7381e6f5..29472cff29 100644 --- a/collects/meta/drdr/config.ss +++ b/collects/meta/drdr/config.ss @@ -9,7 +9,7 @@ (drdr-directory "/opt/svn/drdr") (git-path "/usr/bin/git") (Xvfb-path "/usr/bin/Xvfb") -(fluxbox-path "/usr/bin/fluxbox")) +(fluxbox-path "/usr/bin/fluxbox") (current-make-install-timeout-seconds (* 90 60)) (current-make-timeout-seconds (* 90 60)) (current-subprocess-timeout-seconds 90) From 7c5973cb943d4022123f59ed49683eb45ba11550 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 25 May 2010 15:42:20 -0600 Subject: [PATCH 02/52] Fixing graph display --- collects/meta/drdr/render.ss | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/collects/meta/drdr/render.ss b/collects/meta/drdr/render.ss index 3a9533516e..ba8aa97253 100644 --- a/collects/meta/drdr/render.ss +++ b/collects/meta/drdr/render.ss @@ -203,7 +203,7 @@ path))]) changes)))))] [else - 'nbsp])) + '" "])) (define (footer) `(div ([id "footer"]) @@ -264,7 +264,7 @@ (tr (td "Duration:") (td ,(format-duration-ms dur))) (tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity ""))) (tr (td "Exit Code:") (td ,(if (exit? log) (number->string (exit-code log)) ""))) - (tr (td nbsp) (td (a ([href ,scm-url]) "View File")))) + (tr (td " ") (td (a ([href ,scm-url]) "View File")))) ,(if (lc-zero? changed) "" `(div ([class "error"]) @@ -287,14 +287,18 @@ (img ([src ,png-path])))))]) (make-cdata #f #f - (file->string - (path-timing-html (substring (path->string* the-base-path) 1))))) + (local [(define content + (file->string + (path-timing-html (substring (path->string* the-base-path) 1))))] + #;(regexp-replace* #rx"&(?![a-z]+;)" content "\\&\\1") + (regexp-replace* #rx">" content ">")) + )) ,(footer))))])])) (define (number->string/zero v) (cond [(zero? v) - 'nbsp] + '" "] [else (number->string v)])) @@ -421,7 +425,7 @@ ,(if directory? (number->string/zero v) (if (zero? v) - 'nbsp + '" " checkmark-entity)))) (list timeout unclean stderr changes)) (td ,responsible-party))]) @@ -444,7 +448,7 @@ (td ,(number->string/zero (lc->number tot-unclean))) (td ,(number->string/zero (lc->number tot-stderr))) (td ,(number->string/zero (lc->number tot-changes))) - (td nbsp)))) + (td " ")))) ,(footer))))])) (define (show-help req) @@ -837,6 +841,15 @@ [((integer-arg) "") show-revision] [((integer-arg) (string-arg) ...) show-file])) +#;(define (xml-dispatch req) + (define xe (top-dispatch req)) + (define full + (make-xexpr-response xe #:mime-type #"application/xhtml+xml")) + (struct-copy response/full full + [body (list* + #"\n" + (response/full-body full))])) + (date-display-format 'iso-8601) (cache/file-mode 'no-cache) (serve/servlet top-dispatch From c9d0bd10a1a617931b420471bb300253f84ae58a Mon Sep 17 00:00:00 2001 From: dvanhorn Date: Tue, 25 May 2010 20:24:21 -0400 Subject: [PATCH 03/52] Added remf to unstable/list. Signed-off-by: Jay McCarthy --- collects/tests/unstable/list.rkt | 9 +++++++++ collects/unstable/list.rkt | 10 ++++++++++ collects/unstable/scribblings/list.scrbl | 15 +++++++++++++++ 3 files changed, 34 insertions(+) create mode 100644 collects/tests/unstable/list.rkt diff --git a/collects/tests/unstable/list.rkt b/collects/tests/unstable/list.rkt new file mode 100644 index 0000000000..fedd410ecc --- /dev/null +++ b/collects/tests/unstable/list.rkt @@ -0,0 +1,9 @@ +#lang scheme +(require unstable/list) +(require tests/eli-tester) +(test + (remf positive? '()) => '() + (remf positive? '(1 -2 3 4 -5)) => '(-2 3 4 -5) + (remf even? '(1 -2 3 4 -5)) => '(1 3 4 -5) + (remf (λ (x) #f) '(1 -2 3 4 -5)) => '(1 -2 3 4 -5)) + diff --git a/collects/unstable/list.rkt b/collects/unstable/list.rkt index ab35a6f026..f8b964d713 100644 --- a/collects/unstable/list.rkt +++ b/collects/unstable/list.rkt @@ -112,3 +112,13 @@ (provide map/values) +;; dvanhorn added: + +(define (remf f ls) + (cond [(null? ls) '()] + [(f (car ls)) (cdr ls)] + [else + (cons (car ls) + (remf f (cdr ls)))])) + +(provide/contract [remf (-> procedure? list? list?)]) diff --git a/collects/unstable/scribblings/list.scrbl b/collects/unstable/scribblings/list.scrbl index 76509f6291..3bc0a268fe 100644 --- a/collects/unstable/scribblings/list.scrbl +++ b/collects/unstable/scribblings/list.scrbl @@ -103,3 +103,18 @@ Produces lists of the respective values of @racket[f] applied to the elements in } +@addition{David Van Horn} + +@defproc[(remf [pred procedure?] + [lst list?]) + list?]{ +Returns a list that is like @racket[lst], omitting the first element of @racket[lst] +for which @racket[pred] produces a true value. + +@defexamples[ +#:eval the-eval +(remf negative? '(1 -2 3 4 -5)) +] + +} + From 016a4fa12c69f9059ba99dfb5744bfe0cfe3a8a2 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 26 May 2010 10:09:01 -0600 Subject: [PATCH 04/52] Setting responsible --- collects/meta/props | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/meta/props b/collects/meta/props index 66280c2ea7..7d3ffe1494 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1802,6 +1802,7 @@ path/s is either such a string or a list of them. "collects/tests/units/test-unit.rktl" drdr:command-line (racket "-f" *) "collects/tests/unstable/byte-counting-port.rkt" responsible (jay) "collects/tests/unstable/generics.rkt" responsible (jay) +"collects/tests/unstable/list.rkt" responsible (jay) "collects/tests/unstable/srcloc.rktl" responsible (cce) drdr:command-line (racket "-f" *) "collects/tests/utils" responsible (unknown) "collects/tests/utils/gui.rkt" drdr:command-line (gracket-text "-t" *) From c3d07af8d38ccc55c5c903575723bbba4f3c9942 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 26 May 2010 13:16:36 -0600 Subject: [PATCH 05/52] Fixing sloppy rename. Include in release. --- collects/rackunit/info.rkt | 6 ++--- collects/rackunit/private/gui/config.rkt | 4 ++-- collects/rackunit/private/gui/controller.rkt | 4 ++-- collects/rackunit/private/gui/view.rkt | 6 ++--- .../scribblings/acknowledgements.scrbl | 6 ++--- collects/rackunit/scribblings/api.scrbl | 2 +- collects/rackunit/scribblings/check.scrbl | 4 ++-- .../scribblings/compound-testing.scrbl | 2 +- .../rackunit/scribblings/control-flow.scrbl | 2 +- collects/rackunit/scribblings/misc.scrbl | 2 +- collects/rackunit/scribblings/overview.scrbl | 4 ++-- .../rackunit/scribblings/philosophy.scrbl | 24 +++++++++---------- .../rackunit/scribblings/quick-start.scrbl | 16 ++++++------- collects/rackunit/scribblings/rackunit.scrbl | 4 ++-- .../rackunit/scribblings/release-notes.scrbl | 2 +- .../rackunit/scribblings/running-tests.scrbl | 6 ++--- collects/rackunit/scribblings/ui.scrbl | 8 +++---- 17 files changed, 51 insertions(+), 51 deletions(-) diff --git a/collects/rackunit/info.rkt b/collects/rackunit/info.rkt index 00330f9169..45ae33c4be 100644 --- a/collects/rackunit/info.rkt +++ b/collects/rackunit/info.rkt @@ -1,13 +1,13 @@ #lang setup/infotab -(define name "RacUnit") +(define name "RackUnit") -(define blurb '((p "RacUnit is a unit testing framework based on the " +(define blurb '((p "RackUnit is a unit testing framework based on the " " Extreme Programming unit test frameworks"))) (define scribblings '(("scribblings/rackunit.scrbl" (multi-page) (tool)))) (define tools '[("tool.rkt")]) -(define tool-names '["RacUnit DrRacket integration"]) +(define tool-names '["RackUnit DrRacket integration"]) (define homepage "http://schematics.sourceforge.net/") (define url "http://schematics.sourceforge.net/") diff --git a/collects/rackunit/private/gui/config.rkt b/collects/rackunit/private/gui/config.rkt index de80e95e9c..74d22b4bdc 100644 --- a/collects/rackunit/private/gui/config.rkt +++ b/collects/rackunit/private/gui/config.rkt @@ -14,11 +14,11 @@ ;; Some of these are obsolete, given the preferences above. (define DETAILS-CANVAS-INIT-WIDTH 400) -(define FRAME-LABEL "RacUnit") +(define FRAME-LABEL "RackUnit") (define FRAME-INIT-HEIGHT 400) (define TREE-INIT-WIDTH 240) (define TREE-COLORIZE-CASES #t) -(define DIALOG-ERROR-TITLE "RacUnit: Error") +(define DIALOG-ERROR-TITLE "RackUnit: Error") (define STATUS-SUCCESS 'success) (define STATUS-FAILURE 'failure) (define STATUS-ERROR 'error) diff --git a/collects/rackunit/private/gui/controller.rkt b/collects/rackunit/private/gui/controller.rkt index 9d45086d39..51cebb6f3b 100644 --- a/collects/rackunit/private/gui/controller.rkt +++ b/collects/rackunit/private/gui/controller.rkt @@ -25,9 +25,9 @@ ;; check-ready : -> void (define/private (check-ready) (unless view - (error 'racunit "The RacUnit GUI is no longer running.")) + (error 'racunit "The RackUnit GUI is no longer running.")) (when (get-locked?) - (error 'racunit "The RacUnit GUI is locked and not accepting tests."))) + (error 'racunit "The RackUnit GUI is locked and not accepting tests."))) ;; create-model : test suite<%>/#f -> result<%> (define/public (create-model test parent) diff --git a/collects/rackunit/private/gui/view.rkt b/collects/rackunit/private/gui/view.rkt index 84aec27b81..0372b9926c 100644 --- a/collects/rackunit/private/gui/view.rkt +++ b/collects/rackunit/private/gui/view.rkt @@ -308,11 +308,11 @@ still be there, just not visible? (super-new (width width) (height height)) (send (get-help-menu) delete) - (let ([racunit-menu + (let ([rackunit-menu (new menu% - (label "RacUnit") + (label "RackUnit") (parent (get-menu-bar)))]) - (menu-option/notify-box racunit-menu + (menu-option/notify-box rackunit-menu "Lock" (get-field locked? controller))) diff --git a/collects/rackunit/scribblings/acknowledgements.scrbl b/collects/rackunit/scribblings/acknowledgements.scrbl index bdab1093a4..dff31b08c2 100644 --- a/collects/rackunit/scribblings/acknowledgements.scrbl +++ b/collects/rackunit/scribblings/acknowledgements.scrbl @@ -3,7 +3,7 @@ @title{Acknowlegements} -The following people have contributed to RacUnit: +The following people have contributed to RackUnit: @itemize[ @item{Robby Findler pushed me to release version 3} @@ -12,7 +12,7 @@ The following people have contributed to RacUnit: suggested renaming @racket[test/text-ui]} @item{Dave Gurnell reported a bug in check-not-exn and - suggested improvements to RacUnit} + suggested improvements to RackUnit} @item{Danny Yoo reported a bug in and provided a fix for trim-current-directory} @@ -30,7 +30,7 @@ The following people have contributed to RacUnit: @item{Jose A. Ortega Ruiz alerted me a problem in the packaging system and helped fix it.} - @item{Sebastian H. Seidel provided help packaging RacUnit + @item{Sebastian H. Seidel provided help packaging RackUnit into a .plt} @item{Don Blaheta provided the method for grabbing line number diff --git a/collects/rackunit/scribblings/api.scrbl b/collects/rackunit/scribblings/api.scrbl index ea3467d88f..75dee084f6 100644 --- a/collects/rackunit/scribblings/api.scrbl +++ b/collects/rackunit/scribblings/api.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "base.rkt") -@title[#:tag "api"]{RacUnit API} +@title[#:tag "api"]{RackUnit API} @defmodule[rackunit #:use-sources (rackunit)] diff --git a/collects/rackunit/scribblings/check.scrbl b/collects/rackunit/scribblings/check.scrbl index 5c50ce3f90..869bfc25b6 100644 --- a/collects/rackunit/scribblings/check.scrbl +++ b/collects/rackunit/scribblings/check.scrbl @@ -3,7 +3,7 @@ @title{Checks} -Checks are the basic building block of RacUnit. A check +Checks are the basic building block of RackUnit. A check checks some condition. If the condition holds the check evaluates to @racket[#t]. If the condition doesn't hold the check raises an instance of @racket[exn:test:check] with @@ -16,7 +16,7 @@ their arguments. You can use check as first class functions, though you will lose precision in the reported source locations if you do so. -The following are the basic checks RacUnit provides. You +The following are the basic checks RackUnit provides. You can create your own checks using @racket[define-check]. @defproc[(check (op (-> any any any)) diff --git a/collects/rackunit/scribblings/compound-testing.scrbl b/collects/rackunit/scribblings/compound-testing.scrbl index 8a0fb71e72..8b5016ef54 100644 --- a/collects/rackunit/scribblings/compound-testing.scrbl +++ b/collects/rackunit/scribblings/compound-testing.scrbl @@ -147,7 +147,7 @@ creates test cases within the suite, with the given names and body expressions. As far I know no-one uses this macro, so it might disappear -in future versions of RacUnit.} +in future versions of RackUnit.} } diff --git a/collects/rackunit/scribblings/control-flow.scrbl b/collects/rackunit/scribblings/control-flow.scrbl index 59758d4c17..56a73077f3 100644 --- a/collects/rackunit/scribblings/control-flow.scrbl +++ b/collects/rackunit/scribblings/control-flow.scrbl @@ -48,5 +48,5 @@ file. The after action deletes it. This somewhat curious macro evaluates the given tests in a context where @racket[current-test-case-around] is parameterized to @racket[test-suite-test-case-around]. This -has been useful in testing RacUnit. It might be useful +has been useful in testing RackUnit. It might be useful for you if you create test cases that create test cases.} diff --git a/collects/rackunit/scribblings/misc.scrbl b/collects/rackunit/scribblings/misc.scrbl index f3cdf3bf35..2b0c3f303a 100644 --- a/collects/rackunit/scribblings/misc.scrbl +++ b/collects/rackunit/scribblings/misc.scrbl @@ -14,7 +14,7 @@ Note that @racket[require/expose] can be a bit fragile, especially when mixed with compiled code. Use at your own risk! } -This example gets @racket[make-failure-test], which is defined in a RacUnit test: +This example gets @racket[make-failure-test], which is defined in a RackUnit test: @racketblock[ (require/expose rackunit/private/check-test (make-failure-test)) diff --git a/collects/rackunit/scribblings/overview.scrbl b/collects/rackunit/scribblings/overview.scrbl index 8645271c63..bc3aec4e01 100644 --- a/collects/rackunit/scribblings/overview.scrbl +++ b/collects/rackunit/scribblings/overview.scrbl @@ -1,9 +1,9 @@ #lang scribble/doc @(require "base.rkt") -@title{Overview of RacUnit} +@title{Overview of RackUnit} -There are three basic data types in RacUnit: +There are three basic data types in RackUnit: @itemize[ diff --git a/collects/rackunit/scribblings/philosophy.scrbl b/collects/rackunit/scribblings/philosophy.scrbl index bf776e6d4b..4d0434c7b4 100644 --- a/collects/rackunit/scribblings/philosophy.scrbl +++ b/collects/rackunit/scribblings/philosophy.scrbl @@ -1,10 +1,10 @@ #lang scribble/doc @(require "base.rkt") -@title[#:tag "philosophy"]{The Philosophy of RacUnit} +@title[#:tag "philosophy"]{The Philosophy of RackUnit} -RacUnit is designed to allow tests to evolve in step with -the evolution of the program under testing. RacUnit +RackUnit is designed to allow tests to evolve in step with +the evolution of the program under testing. RackUnit scales from the unstructed checks suitable for simple programs to the complex structure necessary for large projects. @@ -25,9 +25,9 @@ checking are of the form: (equal? (length '(a b)) 2) ] -RacUnit directly supports this style of testing. A check +RackUnit directly supports this style of testing. A check on its own is a valid test. So the above examples may be -written in RacUnit as: +written in RackUnit as: @racketblock[ (check-equal? (length null) 0) @@ -35,7 +35,7 @@ written in RacUnit as: (check-equal? (length '(a b)) 2) ] -Simple programs now get all the benefits of RacUnit with +Simple programs now get all the benefits of RackUnit with very little overhead. There are limitations to this style of testing that more @@ -45,7 +45,7 @@ it does not make sense to evaluate some expressions if earlier ones have failed. This type of program needs a way to group expressions so that a failure in one group causes evaluation of that group to stop and immediately proceed to -the next group. In RacUnit all that is required is to +the next group. In RackUnit all that is required is to wrap a @racket[test-begin] expression around a group of expressions: @@ -62,7 +62,7 @@ be evaluated. Notice that all the previous tests written in the simple style are still valid. Introducing grouping is a local -change only. This is a key feature of RacUnit's support +change only. This is a key feature of RackUnit's support for the evolution of the program. The programmer may wish to name a group of tests. This is @@ -79,7 +79,7 @@ Most programs will stick with this style. However, programmers writing very complex programs may wish to maintain separate groups of tests for different parts of the program, or run their tests in different ways to the normal -RacUnit manner (for example, test results may be logged +RackUnit manner (for example, test results may be logged for the purpose of improving software quality, or they may be displayed on a website to indicate service quality). For these programmers it is necessary to delay the execution of @@ -104,15 +104,15 @@ outside the suite continue to evaluate as before. @section{Historical Context} Most testing frameworks, including earlier versions of -RacUnit, support only the final form of testing. This is +RackUnit, support only the final form of testing. This is likely due to the influence of the SUnit testing framework, -which is the ancestor of RacUnit and the most widely used +which is the ancestor of RackUnit and the most widely used frameworks in Java, .Net, Python, and Ruby, and many other languages. That this is insufficient for all users is apparent if one considers the proliferation of ``simpler'' testing frameworks in Racket such as SRFI-78, or the practice of beginner programmers. Unfortunately these simpler methods are inadequate for testing larger -systems. To the best of my knowledge RacUnit is the only +systems. To the best of my knowledge RackUnit is the only testing framework that makes a conscious effort to support the testing style of all levels of programmer. diff --git a/collects/rackunit/scribblings/quick-start.scrbl b/collects/rackunit/scribblings/quick-start.scrbl index a7088ed85a..ed4c80f6a9 100644 --- a/collects/rackunit/scribblings/quick-start.scrbl +++ b/collects/rackunit/scribblings/quick-start.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "base.rkt") -@title[#:tag "quick-start"]{Quick Start Guide for RacUnit} +@title[#:tag "quick-start"]{Quick Start Guide for RackUnit} Suppose we have code contained in @tt{file.rkt}, which implements buggy versions of @racket[+] and @racket[-] @@ -24,10 +24,10 @@ racket/base my-*) ] -We want to test this code with RacUnit. We start by +We want to test this code with RackUnit. We start by creating a file called @tt{file-test.rkt} to contain our tests. At the top of @tt{file-test.rkt} we import -RacUnit and @tt{file.rkt}: +RackUnit and @tt{file.rkt}: @racketmod[ racket/base @@ -43,7 +43,7 @@ Now we add some tests to check our library: (check-equal? (my-* 1 2) 2 "Simple multiplication") ] -This is all it takes to define tests in RacUnit. Now +This is all it takes to define tests in RackUnit. Now evaluate this file and see if the library is correct. Here's the result I get: @@ -63,13 +63,13 @@ expected: 2 The first @racket[#t] indicates the first test passed. The second test failed, as shown by the message. -Requiring RacUnit and writing checks is all you need to +Requiring RackUnit and writing checks is all you need to get started testing, but let's take a little bit more time to look at some features beyond the essentials. Let's say we want to check that a number of properties hold. How do we do this? So far we've only seen checks of a -single expression. In RacUnit a check is always a single +single expression. In RackUnit a check is always a single expression, but we can group checks into units called test cases. Here's a simple test case written using the @racket[test-begin] form: @@ -147,7 +147,7 @@ tests, allowing you to choose how you run your tests. You might, for example, print the results to the screen or log them to a file. -Let's run our tests, using RacUnit's simple textual user +Let's run our tests, using RackUnit's simple textual user interface (there are fancier interfaces available but this will do for our example). In @tt{file-test.rkt} add the following lines: @@ -161,6 +161,6 @@ following lines: Now evaluate the file and you should see similar output again. -These are the basics of RacUnit. Refer to the +These are the basics of RackUnit. Refer to the documentation below for more advanced topics, such as defining your own checks. Have fun! diff --git a/collects/rackunit/scribblings/rackunit.scrbl b/collects/rackunit/scribblings/rackunit.scrbl index aa98ed24b1..c8bdc2b873 100644 --- a/collects/rackunit/scribblings/rackunit.scrbl +++ b/collects/rackunit/scribblings/rackunit.scrbl @@ -1,12 +1,12 @@ #lang scribble/doc @(require "base.rkt") -@title{@bold{RacUnit}: Unit Testing for Racket} +@title{@bold{RackUnit}: Unit Testing for Racket} @author[(author+email "Noel Welsh" "noelwelsh@gmail.com") (author+email "Ryan Culpepper" "ryan_sml@yahoo.com")] -RacUnit is a unit-testing framework for Racket. It +RackUnit is a unit-testing framework for Racket. It is designed to handle the needs of all Racket programmers, from novices to experts. diff --git a/collects/rackunit/scribblings/release-notes.scrbl b/collects/rackunit/scribblings/release-notes.scrbl index 2015dc4822..a4f0bed673 100644 --- a/collects/rackunit/scribblings/release-notes.scrbl +++ b/collects/rackunit/scribblings/release-notes.scrbl @@ -12,7 +12,7 @@ There are also miscellaneous Scribble fixes. @section{Version 3} -This version of RacUnit is largely backwards compatible +This version of RackUnit is largely backwards compatible with version 2 but there are significant changes to the underlying model, justifying incrementing the major version number. These changes are best explained in diff --git a/collects/rackunit/scribblings/running-tests.scrbl b/collects/rackunit/scribblings/running-tests.scrbl index efe32c6da9..af37007145 100644 --- a/collects/rackunit/scribblings/running-tests.scrbl +++ b/collects/rackunit/scribblings/running-tests.scrbl @@ -3,14 +3,14 @@ @title[#:tag "running"]{Programmatically Running Tests and Inspecting Results} -RacUnit provides an API for running tests, from which +RackUnit provides an API for running tests, from which custom UIs can be created. @section{Result Types} @defstruct[(exn:test exn) ()]{ -The base structure for RacUnit exceptions. You should +The base structure for RackUnit exceptions. You should never catch instances of this type, only the subtypes documented below.} @@ -187,7 +187,7 @@ recorded, and so on. To do so the functions that run the test cases need to know what type the test case has, and hence is is necessary to provide this information. -If you've made it this far you truly are a master RacUnit +If you've made it this far you truly are a master RackUnit hacker. As a bonus prize we'll just mention that the code in hash-monad.rkt and monad.rkt might be of interest for constructing user interfaces. The API is still in flux, so diff --git a/collects/rackunit/scribblings/ui.scrbl b/collects/rackunit/scribblings/ui.scrbl index 3015f1d8d0..f77e6ccc94 100644 --- a/collects/rackunit/scribblings/ui.scrbl +++ b/collects/rackunit/scribblings/ui.scrbl @@ -3,7 +3,7 @@ @title[#:tag "ui"]{User Interfaces} -RacUnit provides a textual and a graphical user interface +RackUnit provides a textual and a graphical user interface @section{Textual User Interface} @@ -35,13 +35,13 @@ information. @defmodule[rackunit/gui] -RacUnit also provides a GUI test runner, available from the +RackUnit also provides a GUI test runner, available from the @racketmodname[rackunit/gui] module. @defproc[(test/gui [test (or/c test-case? test-suite?)] ...) any]{ -Creates a new RacUnit GUI window and runs each @racket[test]. The +Creates a new RackUnit GUI window and runs each @racket[test]. The GUI is updated as tests complete. } @@ -49,7 +49,7 @@ GUI is updated as tests complete. @defproc[(make-gui-runner) (-> (or/c test-case? test-suite?) ... any)]{ -Creates a new RacUnit GUI window and returns a procedure that, when +Creates a new RackUnit GUI window and returns a procedure that, when applied, runs the given tests and displays the results in the GUI. } From 28dce6996a5c2eb8cd8489bf5e6b4da7f280fcd1 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 26 May 2010 13:18:02 -0600 Subject: [PATCH 06/52] Forgot one place --- collects/rackunit/private/gui/controller.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/rackunit/private/gui/controller.rkt b/collects/rackunit/private/gui/controller.rkt index 51cebb6f3b..4742523cc6 100644 --- a/collects/rackunit/private/gui/controller.rkt +++ b/collects/rackunit/private/gui/controller.rkt @@ -25,9 +25,9 @@ ;; check-ready : -> void (define/private (check-ready) (unless view - (error 'racunit "The RackUnit GUI is no longer running.")) + (error 'rackunit "The RackUnit GUI is no longer running.")) (when (get-locked?) - (error 'racunit "The RackUnit GUI is locked and not accepting tests."))) + (error 'rackunit "The RackUnit GUI is locked and not accepting tests."))) ;; create-model : test suite<%>/#f -> result<%> (define/public (create-model test parent) From 5c702976c216362aab695a1c973fb17948b23149 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 26 May 2010 15:21:55 -0400 Subject: [PATCH 07/52] A few more stray "racunit"s. --- collects/tests/eli-tester.rkt | 2 +- collects/tests/rackunit/all-rackunit-tests.rkt | 2 +- collects/tests/rackunit/check-info-test.rkt | 10 +++++----- collects/tests/typed-scheme/succeed/fixnum.rkt | 2 +- collects/tests/typed-scheme/succeed/flonum.rkt | 2 +- collects/tests/typed-scheme/succeed/flvector.rkt | 2 +- 6 files changed, 10 insertions(+), 10 deletions(-) diff --git a/collects/tests/eli-tester.rkt b/collects/tests/eli-tester.rkt index 6bb114b90c..01fa685aba 100644 --- a/collects/tests/eli-tester.rkt +++ b/collects/tests/eli-tester.rkt @@ -216,7 +216,7 @@ => '(#"1 test passed\n" #"2 tests passed\n") ) -;; RacUnit stuff +;; RackUnit stuff ;; (examples that should fail modified to ones that shouldn't) #| diff --git a/collects/tests/rackunit/all-rackunit-tests.rkt b/collects/tests/rackunit/all-rackunit-tests.rkt index 2cb4b033b5..86fe329c28 100644 --- a/collects/tests/rackunit/all-rackunit-tests.rkt +++ b/collects/tests/rackunit/all-rackunit-tests.rkt @@ -22,7 +22,7 @@ (define all-rackunit-tests (test-suite - "All RacUnit Tests" + "All RackUnit Tests" check-tests base-tests check-info-tests diff --git a/collects/tests/rackunit/check-info-test.rkt b/collects/tests/rackunit/check-info-test.rkt index a95ffe6ca4..15e3cbcc6e 100644 --- a/collects/tests/rackunit/check-info-test.rkt +++ b/collects/tests/rackunit/check-info-test.rkt @@ -2,22 +2,22 @@ ;;; ---- Tests for check-util ;;; Time-stamp: <2009-06-11 17:03:21 noel> ;;; -;;; Copyright (C) 2003 by Noel Welsh. +;;; Copyright (C) 2003 by Noel Welsh. ;;; -;;; This file is part of RacUnit. +;;; This file is part of RackUnit. -;;; RacUnit is free software; you can redistribute it and/or +;;; RackUnit is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public ;;; License as published by the Free Software Foundation; either ;;; version 2.1 of the License, or (at your option) any later version. -;;; RacUnitis distributed in the hope that it will be useful, +;;; RackUnit is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; You should have received a copy of the GNU Lesser General Public -;;; License along with RacUnit; if not, write to the Free Software +;;; License along with RackUnit; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Author: Noel Welsh diff --git a/collects/tests/typed-scheme/succeed/fixnum.rkt b/collects/tests/typed-scheme/succeed/fixnum.rkt index 27e50ba56d..b345dd1b61 100644 --- a/collects/tests/typed-scheme/succeed/fixnum.rkt +++ b/collects/tests/typed-scheme/succeed/fixnum.rkt @@ -10,7 +10,7 @@ ;; really badly wrong. (: check (All (a) ((a a -> Boolean) a a -> Boolean))) -;; Simple check function as RacUnit doesn't work in Typed Scheme (yet) +;; Simple check function as RackUnit doesn't work in Typed Scheme (yet) (define (check f a b) (if (f a b) #t diff --git a/collects/tests/typed-scheme/succeed/flonum.rkt b/collects/tests/typed-scheme/succeed/flonum.rkt index 0c709e64de..58139c7141 100644 --- a/collects/tests/typed-scheme/succeed/flonum.rkt +++ b/collects/tests/typed-scheme/succeed/flonum.rkt @@ -5,7 +5,7 @@ scheme/unsafe/ops) (: check (All (a) ((a a -> Boolean) a a -> Boolean))) -;; Simple check function as RacUnit doesn't work in Typed Scheme (yet) +;; Simple check function as RackUnit doesn't work in Typed Scheme (yet) (define (check f a b) (if (f a b) #t diff --git a/collects/tests/typed-scheme/succeed/flvector.rkt b/collects/tests/typed-scheme/succeed/flvector.rkt index 255776edf9..4a359a43f7 100644 --- a/collects/tests/typed-scheme/succeed/flvector.rkt +++ b/collects/tests/typed-scheme/succeed/flvector.rkt @@ -11,7 +11,7 @@ ;; really badly wrong. (: check (All (a) ((a a -> Boolean) a a -> Boolean))) -;; Simple check function as RacUnit doesn't work in Typed Scheme (yet) +;; Simple check function as RackUnit doesn't work in Typed Scheme (yet) (define (check f a b) (if (f a b) #t From 920870966f9461052a51555fb2009df62bad4677 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 26 May 2010 15:44:12 -0400 Subject: [PATCH 08/52] Fix the starter executable too. --- collects/setup/unixstyle-install.rkt | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/collects/setup/unixstyle-install.rkt b/collects/setup/unixstyle-install.rkt index 07016c7d05..3f1b617540 100644 --- a/collects/setup/unixstyle-install.rkt +++ b/collects/setup/unixstyle-install.rkt @@ -12,8 +12,8 @@ ;; (interactive, undo-on-error, create-uninstaller) ;; - `copy': similar to `move', but copies instead of moving ;; - `make-install-copytree': copies some toplevel directories, skips ".*" -;; and compiled subdirs, and rewrites "config.ss", but no uninstaller (used -;; by `make install') (requires an additional `origtree' argument) +;; and "compiled" subdirs, and rewrites "config.ss", but no uninstaller +;; (used by `make install') (requires an additional `origtree' argument) ;; - `make-install-destdir-fix': fixes paths in binaries, laucnhers, and ;; config.ss (used by `make install' to fix a DESTDIR) (requires exactly ;; the same args as `make-install-copytree' (prefixed) and requires a @@ -21,7 +21,7 @@ ;; * pltdir: The source plt directory ;; * Path names that should be moved/copied (bin, collects, doc, lib, ...) -#lang scheme/base +#lang racket/base (define args (vector->list (current-command-line-arguments))) @@ -101,7 +101,7 @@ (define skip-filter (lambda (p) #f)) ;; copy a file or a directory (recursively), preserving time stamps -;; (mzscheme's copy-file preservs permission bits) +;; (racket's copy-file preservs permission bits) (define (cp src dst) (let loop ([src src] [dst dst]) (let ([time! (lambda () @@ -179,7 +179,7 @@ (regexp-replace* #rx"[\"`'$\\]" (dir: 'bin) "\\\\&")) (write-bytes buf (current-output-port) (cdadr m)))))) (let ([magic (with-input-from-file file (lambda () (read-bytes 10)))]) - (cond [(or (regexp-match #rx#"^\177ELF" magic) + (cond [(or (regexp-match #rx#"^\177ELF" magic) (regexp-match #rx#"^\316\372\355\376" magic)) (let ([temp (format "~a-temp-for-install" (regexp-replace* #rx"/" file "_"))]) @@ -194,11 +194,13 @@ (fix-script file)] [else (error (format "unknown executable: ~a" file))]))) -(define (fix-executables bindir . binfiles) - (parameterize ([current-directory bindir]) - (let ([binfiles (if (pair? binfiles) (car binfiles) (ls))]) - (for-each (lambda (f) (when (file-exists? f) (fix-executable f))) - binfiles)))) +(define (fix-executables [binfiles #f]) + (parameterize ([current-directory (dir: 'bin)]) + (for ([f (in-list (or binfiles (ls)))] #:when (file-exists? f)) + (fix-executable f))) + ;; fix the starter executable too + (parameterize ([current-directory (dir: 'libplt)]) + (when (file-exists "starter") (fix-executable "starter")))) ;; remove and record all empty dirs (define (remove-empty-dirs dir) @@ -386,7 +388,7 @@ (define binfiles (ls "bin")) ; see below (do-tree "bin" 'bin) (do-tree "collects" 'collects) - (do-tree "doc" 'doc #:missing 'skip) ; not included in mz distros + (do-tree "doc" 'doc #:missing 'skip) ; not included in text distros ;; (do-tree ??? 'lib) ; shared stuff goes here (do-tree "include" 'includeplt) (do-tree "lib" 'libplt) @@ -403,7 +405,7 @@ (when (and move? (not (null? (ls)))) (error (format "leftovers in source tree: ~s" (ls)))) ;; we need to know which files need fixing - (fix-executables (dir: 'bin) binfiles) + (fix-executables binfiles) (write-uninstaller) (write-config)) (when move? @@ -442,7 +444,7 @@ ;; no need to send an explicit binfiles argument -- this function is used ;; only when DESTDIR is present, so we're installing to a directory that ;; has only our binaries - (fix-executables bindir) + (fix-executables) (unless origtree? (write-config collectsdir))) ;; -------------------------------------------------------------------------- From 8675dc69af8ad3a56f88322c3364c75119754a15 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 26 May 2010 15:47:08 -0400 Subject: [PATCH 09/52] The uninstaller is called "uninstall-racket", a few more "plt" leftovers. --- collects/setup/unixstyle-install.rkt | 44 ++++++++++++++-------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/collects/setup/unixstyle-install.rkt b/collects/setup/unixstyle-install.rkt index 3f1b617540..cf1f676315 100644 --- a/collects/setup/unixstyle-install.rkt +++ b/collects/setup/unixstyle-install.rkt @@ -1,13 +1,13 @@ -;; This file is used to move the PLT tree as part of a Unix sh-installer (when -;; it works in unix-style mode) and similar situations. When possible (`move' -;; mode), this is done carefully (undoing changes if there is an error), and a -;; plt-uninstall script is generated. It is also used to change an already -;; existing tree (eg, when DESTDIR is used) and to copy a tree (possibly part -;; of `make install'). There is no good cmdline interface, since it is -;; internal, and should be as independent as possible (it moves the collection -;; tree). Expects these arguments: +;; This file is used to move the Racket tree as part of a Unix sh-installer +;; (when it works in unix-style mode) and similar situations. When possible +;; (`move' mode), this is done carefully (undoing changes if there is an +;; error), and a racket-uninstall script is generated. It is also used to +;; change an already existing tree (eg, when DESTDIR is used) and to copy a +;; tree (possibly part of `make install'). There is no good cmdline interface, +;; since it is internal, and should be as independent as possible (it moves the +;; collection tree). Expects these arguments: ;; * An operation name: -;; - `move': move a relative installation from `pltdir' to an absolute +;; - `move': move a relative installation from `rktdir' to an absolute ;; installation in the given paths (used by the shell installers) ;; (interactive, undo-on-error, create-uninstaller) ;; - `copy': similar to `move', but copies instead of moving @@ -18,7 +18,7 @@ ;; config.ss (used by `make install' to fix a DESTDIR) (requires exactly ;; the same args as `make-install-copytree' (prefixed) and requires a ;; DESTDIR setting) -;; * pltdir: The source plt directory +;; * rktdir: The source racket directory ;; * Path names that should be moved/copied (bin, collects, doc, lib, ...) #lang racket/base @@ -30,9 +30,9 @@ (begin0 (car args) (set! args (cdr args)))) (define op (string->symbol (get-arg))) -(define pltdir (get-arg)) +(define rktdir (get-arg)) (define dirs (map (lambda (name) (list name (get-arg))) - '(bin collects doc lib includeplt libplt man #|src|#))) + '(bin collects doc lib includerkt librkt man #|src|#))) (define (dir: name) (cadr (or (assq name dirs) (error 'getdir "unknown dir name: ~e" name)))) @@ -199,7 +199,7 @@ (for ([f (in-list (or binfiles (ls)))] #:when (file-exists? f)) (fix-executable f))) ;; fix the starter executable too - (parameterize ([current-directory (dir: 'libplt)]) + (parameterize ([current-directory (dir: 'librkt)]) (when (file-exists "starter") (fix-executable "starter")))) ;; remove and record all empty dirs @@ -239,7 +239,7 @@ path-changes)) (define (write-uninstaller) - (define uninstaller (make-path (dir: 'bin) "plt-uninstall")) + (define uninstaller (make-path (dir: 'bin) "racket-uninstall")) (printf "Writing uninstaller at: ~a...\n" uninstaller) (register-change! 'file uninstaller) (with-output-to-file uninstaller #:exists 'replace @@ -294,8 +294,8 @@ (printf " (define doc-dir ~s)\n" (dir: 'doc)) (when (eq? 'shared (system-type 'link)) ; never true for now (printf " (define dll-dir ~s)\n" (dir: 'lib))) - (printf " (define lib-dir ~s)\n" (dir: 'libplt)) - (printf " (define include-dir ~s)\n" (dir: 'includeplt)) + (printf " (define lib-dir ~s)\n" (dir: 'librkt)) + (printf " (define include-dir ~s)\n" (dir: 'includerkt)) (printf " (define bin-dir ~s)\n" (dir: 'bin)) (printf " (define absolute-installation? #t))\n"))) ;; recompile & set times as if nothing happened (don't remove .dep) @@ -381,7 +381,7 @@ (define (move/copy-distribution move?) (define do-tree (move/copy-tree move?)) - (current-directory pltdir) + (current-directory rktdir) (when (ormap (lambda (p) (regexp-match #rx"[.]so" p)) (ls "lib")) (error "Cannot handle distribution of shared-libraries (yet)")) (with-handlers ([exn? (lambda (e) (undo-changes) (raise e))]) @@ -390,8 +390,8 @@ (do-tree "collects" 'collects) (do-tree "doc" 'doc #:missing 'skip) ; not included in text distros ;; (do-tree ??? 'lib) ; shared stuff goes here - (do-tree "include" 'includeplt) - (do-tree "lib" 'libplt) + (do-tree "include" 'includerkt) + (do-tree "lib" 'librkt) (do-tree "man" 'man) ;; (when (and (not (equal? (dir: 'src) "")) (directory-exists? "src")) ;; (do-tree "src" 'src)) @@ -409,13 +409,13 @@ (write-uninstaller) (write-config)) (when move? - (current-directory (dirname pltdir)) - (delete-directory pltdir))) + (current-directory (dirname rktdir)) + (delete-directory rktdir))) (define (make-install-copytree) (define copytree (move/copy-tree #f)) (define origtree? (equal? "yes" (get-arg))) - (current-directory pltdir) + (current-directory rktdir) (set! skip-filter ; skip all dot-names and compiled subdirs (lambda (p) (regexp-match? #rx"^(?:[.].*|compiled)$" (basename p)))) (with-handlers ([exn? (lambda (e) (undo-changes) (raise e))]) From d346575d3674d15c1c2b0bc9b248030b6e39c1d8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 May 2010 14:08:32 -0600 Subject: [PATCH 10/52] fix typo in dynext linker spec for x86_64 Darwin --- collects/dynext/link-unit.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/dynext/link-unit.rkt b/collects/dynext/link-unit.rkt index 0afb97eb85..bcbd348b90 100644 --- a/collects/dynext/link-unit.rkt +++ b/collects/dynext/link-unit.rkt @@ -140,7 +140,7 @@ (format "-bE:~a/ext.exp" (include-dir)) "-bnoentry")] [(parisc-hpux) (list "-b")] - [(ppc-macosx ppc-darwin x86_64-macosx x86_86-darwin) mac-link-flags] + [(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) mac-link-flags] [(i386-macosx i386-darwin) (append mac-link-flags '("-m32"))] [(i386-cygwin) win-gcc-linker-flags] [else (list "-fPIC" "-shared")])) From 51dfbe6bc200d550c0ac639d31f824643f0aefb8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 May 2010 14:14:02 -0600 Subject: [PATCH 11/52] fix starter app's collect path on install --- src/racket/Makefile.in | 1 + 1 file changed, 1 insertion(+) diff --git a/src/racket/Makefile.in b/src/racket/Makefile.in index c0594f7b5d..8042ac48b0 100644 --- a/src/racket/Makefile.in +++ b/src/racket/Makefile.in @@ -282,6 +282,7 @@ unix-install: cd ..; rm -f "$(DESTDIR)$(bindir)/racket@MMM_INSTALLED@" cd ..; cp racket/starter "$(DESTDIR)$(libpltdir)/starter" cd ..; $(STRIP_DEBUG) "$(DESTDIR)$(libpltdir)/starter" + ./racket@CGC@ -cu "$(srcdir)/collects-path.rkt" "$(DESTDIR)$(libpltdir)/starter" @COLLECTS_PATH@ cd ..; echo 'CC=@CC@' > "$(BUILDINFO)" cd ..; echo 'CFLAGS=@CFLAGS@ @PREFLAGS@ @COMPFLAGS@' >> "$(BUILDINFO)" cd ..; echo 'OPTIONS=@OPTIONS@' >> "$(BUILDINFO)" From a8130eb7c389dd2efba0f7ff2b77c45a90e1bc43 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 May 2010 14:27:37 -0600 Subject: [PATCH 12/52] fix typo in unixstyle-install --- collects/setup/unixstyle-install.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/setup/unixstyle-install.rkt b/collects/setup/unixstyle-install.rkt index cf1f676315..b702633824 100644 --- a/collects/setup/unixstyle-install.rkt +++ b/collects/setup/unixstyle-install.rkt @@ -200,7 +200,7 @@ (fix-executable f))) ;; fix the starter executable too (parameterize ([current-directory (dir: 'librkt)]) - (when (file-exists "starter") (fix-executable "starter")))) + (when (file-exists? "starter") (fix-executable "starter")))) ;; remove and record all empty dirs (define (remove-empty-dirs dir) From 225c08312a3827911d84f0bc540b0dc82f5955c1 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 26 May 2010 13:23:04 -0600 Subject: [PATCH 13/52] Commenting out time display I don't understand --- collects/tests/racket/benchmarks/common/README.txt | 4 +--- collects/tests/racket/benchmarks/common/auto.rkt | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/collects/tests/racket/benchmarks/common/README.txt b/collects/tests/racket/benchmarks/common/README.txt index f8782da7de..6e62ca2825 100644 --- a/collects/tests/racket/benchmarks/common/README.txt +++ b/collects/tests/racket/benchmarks/common/README.txt @@ -22,9 +22,7 @@ run (as reported by --show). Similarly, if the first named implementation/benchmak starts with "no-", the default set is used minus the "no-"-specified implementation/benchmark. -The output is a comment line - ; -and then a series of lines of the form +The output is a series of lines of the form [ ( ) ] where #f means that the information is unavailable, or that the benchmark wasn't run due to an implementation limitation. The diff --git a/collects/tests/racket/benchmarks/common/auto.rkt b/collects/tests/racket/benchmarks/common/auto.rkt index 2bdf46f7fa..4e49d92ac9 100755 --- a/collects/tests/racket/benchmarks/common/auto.rkt +++ b/collects/tests/racket/benchmarks/common/auto.rkt @@ -574,7 +574,7 @@ exec racket -qu "$0" ${1+"$@"} ;; Run benchmarks ------------------------------- - (rprintf "; ~a\n" (date->string (seconds->date (current-seconds)) #t)) + #;(rprintf "; ~a\n" (date->string (seconds->date (current-seconds)) #t)) (parameterize ([current-directory bm-directory]) (for-each (lambda (impl) From 47f6b264a0b38c86af4b62ed5bf3d3d6792f5fda Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 26 May 2010 14:50:06 -0600 Subject: [PATCH 14/52] Specifying when R5RS is required for a benchmark and enabling running from other directories Enabling running all benchmarks in DrDr --- collects/meta/props | 64 ------------------- .../tests/racket/benchmarks/common/README.txt | 2 - .../racket/benchmarks/common/conform.rkt | 2 +- .../racket/benchmarks/common/destruct.rkt | 2 +- .../racket/benchmarks/common/dynamic.rkt | 2 +- .../racket/benchmarks/common/lattice.rkt | 2 +- .../tests/racket/benchmarks/common/maze.rkt | 2 +- .../tests/racket/benchmarks/common/maze2.rkt | 2 +- .../tests/racket/benchmarks/common/peval.rkt | 2 +- .../tests/racket/benchmarks/common/scheme.rkt | 2 +- .../tests/racket/benchmarks/common/sort1.rkt | 2 +- .../racket/benchmarks/common/wrap-common.rkt | 26 ++++++++ .../common/wrap-typed-non-optimizing.rkt | 8 ++- .../common/wrap-typed-optimizing.rkt | 8 ++- .../tests/racket/benchmarks/common/wrap.rkt | 22 +++++-- 15 files changed, 64 insertions(+), 84 deletions(-) create mode 100644 collects/tests/racket/benchmarks/common/wrap-common.rkt diff --git a/collects/meta/props b/collects/meta/props index 7d3ffe1494..a3a7f78fff 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1469,94 +1469,30 @@ path/s is either such a string or a list of them. "collects/tests/racket/beginner-abbr.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/beginner.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/benchmarks/common/auto.rkt" drdr:command-line (racket * "--" "racket" "ctak") -"collects/tests/racket/benchmarks/common/conform.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/cpstack-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/cpstack-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/cpstack-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/ctak-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/ctak-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/ctak-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/ctak.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/dderiv-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/dderiv-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/dderiv-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/deriv-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/deriv-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/deriv-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/destruct.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/div-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/div-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/div-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/div.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/dynamic.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/dynamic2.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/fft-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/fft-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/fft-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/graphs-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/graphs-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/graphs-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/graphs.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/lattice.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/lattice2-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/lattice2-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/lattice2-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/maze.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/maze2.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/mazefun-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/mazefun-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/mazefun-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/mazefun.rkt" drdr:command-line (mzc *) "collects/tests/racket/benchmarks/common/mk-bigloo.rktl" drdr:command-line #f "collects/tests/racket/benchmarks/common/mk-chicken.rktl" drdr:command-line #f "collects/tests/racket/benchmarks/common/mk-gambit.rktl" drdr:command-line #f -"collects/tests/racket/benchmarks/common/nestedloop-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/nestedloop-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/nestedloop-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/nestedloop.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/nfa-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/nfa-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/nfa-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/nothing-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/nothing-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/nothing-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/nqueens-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/nqueens-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/nqueens-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/nqueens.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/paraffins-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/paraffins-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/paraffins-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/paraffins.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/peval.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/puzzle-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/puzzle-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/puzzle-typed.rktl" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/r5rs-wrap.rktl" drdr:command-line (racket "-f" *) -"collects/tests/racket/benchmarks/common/scheme.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/scheme2.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/sort1.rkt" drdr:command-line #f -"collects/tests/racket/benchmarks/common/tak-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/tak-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/tak-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/tak.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/takl-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/takl-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/takl-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/takl.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/takr-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/takr-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/takr-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/takr.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/takr2-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/takr2-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/takr2-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/takr2.rkt" drdr:command-line (mzc *) -"collects/tests/racket/benchmarks/common/triangle-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/triangle-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/triangle-typed.rktl" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f -"collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test") diff --git a/collects/tests/racket/benchmarks/common/README.txt b/collects/tests/racket/benchmarks/common/README.txt index 6e62ca2825..d1aa68dc7f 100644 --- a/collects/tests/racket/benchmarks/common/README.txt +++ b/collects/tests/racket/benchmarks/common/README.txt @@ -29,8 +29,6 @@ benchmark wasn't run due to an implementation limitation. The and parts are #f only when the benchmark wasn't run. -All benchmarks must be run from the directory containing this file. - Most bechmarks were obtained from http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/code/bench/gabriel/ http://www.ccs.neu.edu/home/will/GC/sourcecode.html diff --git a/collects/tests/racket/benchmarks/common/conform.rkt b/collects/tests/racket/benchmarks/common/conform.rkt index 0e5b3cc2cd..aa05146346 100644 --- a/collects/tests/racket/benchmarks/common/conform.rkt +++ b/collects/tests/racket/benchmarks/common/conform.rkt @@ -1,2 +1,2 @@ -(module conform "wrap.ss") +(module conform "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/destruct.rkt b/collects/tests/racket/benchmarks/common/destruct.rkt index c53eb9b7fb..057e6ec9d7 100644 --- a/collects/tests/racket/benchmarks/common/destruct.rkt +++ b/collects/tests/racket/benchmarks/common/destruct.rkt @@ -1,2 +1,2 @@ -(module destruct "wrap.ss") +(module destruct "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/dynamic.rkt b/collects/tests/racket/benchmarks/common/dynamic.rkt index 3c51b44d4c..15a2da7011 100644 --- a/collects/tests/racket/benchmarks/common/dynamic.rkt +++ b/collects/tests/racket/benchmarks/common/dynamic.rkt @@ -1,2 +1,2 @@ -(module dynamic "wrap.ss") +(module dynamic "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/lattice.rkt b/collects/tests/racket/benchmarks/common/lattice.rkt index 333eadfa9f..2394be43d7 100644 --- a/collects/tests/racket/benchmarks/common/lattice.rkt +++ b/collects/tests/racket/benchmarks/common/lattice.rkt @@ -1,2 +1,2 @@ -(module lattice "wrap.ss") +(module lattice "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/maze.rkt b/collects/tests/racket/benchmarks/common/maze.rkt index cd9dd723c9..1073c71769 100644 --- a/collects/tests/racket/benchmarks/common/maze.rkt +++ b/collects/tests/racket/benchmarks/common/maze.rkt @@ -1,2 +1,2 @@ -(module maze "wrap.ss") +(module maze "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/maze2.rkt b/collects/tests/racket/benchmarks/common/maze2.rkt index 83fdc7cf51..d274133073 100644 --- a/collects/tests/racket/benchmarks/common/maze2.rkt +++ b/collects/tests/racket/benchmarks/common/maze2.rkt @@ -1,2 +1,2 @@ -(module maze2 "wrap.ss") +(module maze2 "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/peval.rkt b/collects/tests/racket/benchmarks/common/peval.rkt index 20426697b5..a8c13ef2d4 100644 --- a/collects/tests/racket/benchmarks/common/peval.rkt +++ b/collects/tests/racket/benchmarks/common/peval.rkt @@ -1,2 +1,2 @@ -(module peval "wrap.ss") +(module peval "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/scheme.rkt b/collects/tests/racket/benchmarks/common/scheme.rkt index d2261c7422..ff7ef2a760 100644 --- a/collects/tests/racket/benchmarks/common/scheme.rkt +++ b/collects/tests/racket/benchmarks/common/scheme.rkt @@ -1,2 +1,2 @@ -(module scheme "wrap.ss") +(module scheme "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/sort1.rkt b/collects/tests/racket/benchmarks/common/sort1.rkt index 11a05c85e2..08c94c3d62 100644 --- a/collects/tests/racket/benchmarks/common/sort1.rkt +++ b/collects/tests/racket/benchmarks/common/sort1.rkt @@ -1,2 +1,2 @@ -(module sort1 "wrap.ss") +(module sort1 "wrap.ss" r5rs) diff --git a/collects/tests/racket/benchmarks/common/wrap-common.rkt b/collects/tests/racket/benchmarks/common/wrap-common.rkt new file mode 100644 index 0000000000..05a9e27ffd --- /dev/null +++ b/collects/tests/racket/benchmarks/common/wrap-common.rkt @@ -0,0 +1,26 @@ +#lang racket +(require racket/runtime-path + file/gunzip) + +(define-runtime-path here ".") + +(define files '("input.txt" "dynamic-input.txt")) + +(define (copy-input) + (unless (file-exists? (build-path here "dynamic-input.txt")) + (gunzip (build-path here "dynamic-input.txt.gz") + (lambda (file archive-supplied?) + (build-path here "dynamic-input.txt")))) + (for ([file (in-list files)]) + (define src (build-path here file)) + (define dest (build-path (current-directory) file)) + (unless (equal? (simplify-path src #t) (simplify-path dest #t)) + (make-file-or-directory-link src dest)))) +(define (remove-input) + (for ([file (in-list files)]) + (define src (build-path here file)) + (define dest (build-path (current-directory) file)) + (unless (equal? (simplify-path src #t) (simplify-path dest #t)) + (delete-file dest)))) + +(provide copy-input remove-input) \ No newline at end of file diff --git a/collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt b/collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt index 79ccc456fb..350ba2aa26 100644 --- a/collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt +++ b/collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt @@ -7,9 +7,15 @@ (define-syntax (module-begin stx) (let ([name (symbol->string (syntax-property stx 'enclosing-module-name))]) #`(ts:#%module-begin + (ts:require/typed + "wrap-common.rkt" + [copy-input (-> Void)] + [remove-input (-> Void)]) + (copy-input) (include #,(format "~a.rktl" (substring name 0 (caar (regexp-match-positions #rx"-non-optimizing" - name))))))))) + name))))) + (remove-input))))) diff --git a/collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt b/collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt index 00337d8296..471bb401f9 100644 --- a/collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt +++ b/collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt @@ -7,9 +7,15 @@ (define-syntax (module-begin stx) (let ([name (symbol->string (syntax-property stx 'enclosing-module-name))]) #`(ts:#%module-begin #:optimize + (ts:require/typed + "wrap-common.rkt" + [copy-input (-> Void)] + [remove-input (-> Void)]) + (copy-input) (include #,(format "~a.rktl" (substring name 0 (caar (regexp-match-positions #rx"-optimizing" - name))))))))) + name))))) + (remove-input))))) diff --git a/collects/tests/racket/benchmarks/common/wrap.rkt b/collects/tests/racket/benchmarks/common/wrap.rkt index 8d2c768c5c..c59adfc28a 100644 --- a/collects/tests/racket/benchmarks/common/wrap.rkt +++ b/collects/tests/racket/benchmarks/common/wrap.rkt @@ -1,8 +1,16 @@ +#lang racket +(provide (rename-out (module-begin #%module-begin))) -(module wrap racket - (provide (rename-out (module-begin #%module-begin))) - (require (lib "include.ss")) - (define-syntax (module-begin stx) - (let ([name (syntax-property stx 'enclosing-module-name)]) - #`(#%module-begin - (include #,(format "~a.sch" name)))))) +(require racket/include + "wrap-common.rkt" + (for-syntax racket/list)) + +(define-syntax (module-begin stx) + (define name (syntax-property stx 'enclosing-module-name)) + (define tokens (rest (syntax->datum stx))) + (define r5rs? (memq 'r5rs tokens)) + #`(#%module-begin + (copy-input) + #,@(if r5rs? #'((require r5rs)) #'()) + (include #,(format "~a.sch" name)) + (remove-input))) From 7c294fd108ff4f9eec1a0ddd6a597d44ea12c9a8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 26 May 2010 15:01:37 -0600 Subject: [PATCH 15/52] Accidentally killed the responsibility --- collects/meta/props | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/collects/meta/props b/collects/meta/props index a3a7f78fff..0ed56ea32e 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1469,30 +1469,72 @@ path/s is either such a string or a list of them. "collects/tests/racket/beginner-abbr.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/beginner.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/benchmarks/common/auto.rkt" drdr:command-line (racket * "--" "racket" "ctak") +"collects/tests/racket/benchmarks/common/cpstack-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/cpstack-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/cpstack-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/ctak-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/ctak-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/ctak-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/dderiv-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/dderiv-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/dderiv-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/deriv-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/deriv-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/deriv-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/div-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/div-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/div-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/fft-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/fft-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/fft-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/graphs-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/graphs-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/graphs-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/lattice2-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/lattice2-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/lattice2-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/mazefun-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/mazefun-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/mazefun-typed.rktl" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/mk-bigloo.rktl" drdr:command-line #f "collects/tests/racket/benchmarks/common/mk-chicken.rktl" drdr:command-line #f "collects/tests/racket/benchmarks/common/mk-gambit.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/common/nestedloop-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/nestedloop-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/nestedloop-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/nfa-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/nfa-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/nfa-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/nothing-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/nothing-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/nothing-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/nqueens-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/nqueens-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/nqueens-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/paraffins-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/paraffins-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/paraffins-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/puzzle-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/puzzle-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/puzzle-typed.rktl" responsible (stamourv) drdr:command-line #f "collects/tests/racket/benchmarks/common/r5rs-wrap.rktl" drdr:command-line (racket "-f" *) +"collects/tests/racket/benchmarks/common/tak-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/tak-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/tak-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/takl-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/takl-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/takl-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/takr-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/takr-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/takr-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/takr2-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/takr2-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/takr2-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/triangle-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/triangle-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/common/triangle-typed.rktl" responsible (stamourv) drdr:command-line #f +"collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt" responsible (stamourv) +"collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt" responsible (stamourv) "collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test") From f85b25f59f429de9378e588b574bd569592a3eba Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 May 2010 14:38:30 -0600 Subject: [PATCH 16/52] fix another typo like the one in dynext Merge to v5.0 --- collects/ffi/unsafe/objc.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt index 0f93b08769..397b29674a 100644 --- a/collects/ffi/unsafe/objc.rkt +++ b/collects/ffi/unsafe/objc.rkt @@ -83,7 +83,7 @@ (case (string->symbol (path->string (system-library-subpath #f))) [(i386-macosx i386-darwin) '(1 2 4 8)] [(ppc-macosx ppc-darwin) '(1 2 3 4)] - [(x86_64-macosx x86_86-darwin) + [(x86_64-macosx x86_64-darwin) ;; Do we need more analysis for unaligned fields? '(1 2 3 4 5 6 7 8)])) From 64089c448821abc4854f1b43151dbc453abc6e75 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 May 2010 15:52:46 -0600 Subject: [PATCH 17/52] add --disable-docs configure option --- src/Makefile.in | 2 +- src/configure | 26 +++++++++++++++++++++++++- src/racket/configure.ac | 15 +++++++++++++++ 3 files changed, 41 insertions(+), 2 deletions(-) diff --git a/src/Makefile.in b/src/Makefile.in index 2c8c9440c9..21d82d1ffd 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -54,7 +54,7 @@ both: # Install (common) ---------------------------------------- -SETUP_ARGS = -X "$(DESTDIR)$(collectsdir)" -N "raco setup" -l setup +SETUP_ARGS = -X "$(DESTDIR)$(collectsdir)" -N "raco setup" -l- setup @INSTALL_SETUP_FLAGS@ install: $(MAKE) install-@MAIN_VARIANT@ diff --git a/src/configure b/src/configure index 38af3cf86f..ed1448ba61 100755 --- a/src/configure +++ b/src/configure @@ -749,6 +749,7 @@ CGC CGC_INSTALLED CGC_CAP_INSTALLED MAIN_VARIANT +INSTALL_SETUP_FLAGS subdirs LIBOBJS LTLIBOBJS' @@ -1336,6 +1337,7 @@ Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-gracket compile GRacket as well as Racket (enabled by default) + --enable-docs build docs on install (enabled by default) --enable-gl use OpenGL when available (enabled by default) --enable-xrender use Xrender when available (enabled by default) --enable-xft use Xft when available (enabled by default) @@ -1829,6 +1831,14 @@ else fi +# Check whether --enable-docs was given. +if test "${enable_docs+set}" = set; then + enableval=$enable_docs; +else + enable_docs=yes +fi + + # Check whether --enable-gl was given. if test "${enable_gl+set}" = set; then enableval=$enable_gl; @@ -2246,6 +2256,8 @@ show_explicitly_enabled() show_explicitly_enabled "${enable_cgcdefault}" "CGC as default" +show_explicitly_disabled "${enable_docs}" "Documentation build" + show_explicitly_enabled "${enable_xonx}" "X-on-X" show_explicitly_enabled "${enable_shared}" "Shared libraries" @@ -2349,6 +2361,8 @@ CGC_INSTALLED=cgc CGC_CAP_INSTALLED=CGC MAIN_VARIANT=3m +INSTALL_SETUP_FLAGS= + STRIP_DEBUG=":" ###### OSKit stuff ####### @@ -11980,6 +11994,13 @@ fi fi fi + +############## docs ################ + +if test "${enable_docs}" = "no" ; then + INSTALL_SETUP_FLAGS="${INSTALL_SETUP_FLAGS} -D" +fi + ############## libtool ################ if test "${enable_shared}" = "yes" ; then @@ -12163,6 +12184,8 @@ LIBS="$LIBS $EXTRALIBS" + + @@ -13167,12 +13190,13 @@ CGC!$CGC$ac_delim CGC_INSTALLED!$CGC_INSTALLED$ac_delim CGC_CAP_INSTALLED!$CGC_CAP_INSTALLED$ac_delim MAIN_VARIANT!$MAIN_VARIANT$ac_delim +INSTALL_SETUP_FLAGS!$INSTALL_SETUP_FLAGS$ac_delim subdirs!$subdirs$ac_delim LIBOBJS!$LIBOBJS$ac_delim LTLIBOBJS!$LTLIBOBJS$ac_delim _ACEOF - if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 41; then + if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 42; then break elif $ac_last_try; then { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 diff --git a/src/racket/configure.ac b/src/racket/configure.ac index 229e8501a9..4e96f6593b 100644 --- a/src/racket/configure.ac +++ b/src/racket/configure.ac @@ -26,6 +26,8 @@ AC_CONFIG_HEADERS([racket/mzconfig.h]) AC_ARG_ENABLE(gracket, [ --enable-gracket compile GRacket as well as Racket (enabled by default)], , enable_gracket=yes ) +AC_ARG_ENABLE(docs, [ --enable-docs build docs on install (enabled by default)], , enable_docs=yes) + AC_ARG_ENABLE(gl, [ --enable-gl use OpenGL when available (enabled by default)]) AC_ARG_ENABLE(xrender, [ --enable-xrender use Xrender when available (enabled by default)]) AC_ARG_ENABLE(xft, [ --enable-xft use Xft when available (enabled by default)]) @@ -279,6 +281,8 @@ show_explicitly_enabled() show_explicitly_enabled "${enable_cgcdefault}" "CGC as default" +show_explicitly_disabled "${enable_docs}" "Documentation build" + show_explicitly_enabled "${enable_xonx}" "X-on-X" show_explicitly_enabled "${enable_shared}" "Shared libraries" @@ -382,6 +386,8 @@ CGC_INSTALLED=cgc CGC_CAP_INSTALLED=CGC MAIN_VARIANT=3m +INSTALL_SETUP_FLAGS= + STRIP_DEBUG=":" ###### OSKit stuff ####### @@ -1356,6 +1362,13 @@ if test "${enable_libjpeg}" = "yes" ; then fi fi + +############## docs ################ + +if test "${enable_docs}" = "no" ; then + INSTALL_SETUP_FLAGS="${INSTALL_SETUP_FLAGS} -D" +fi + ############## libtool ################ if test "${enable_shared}" = "yes" ; then @@ -1542,6 +1555,8 @@ AC_SUBST(CGC_INSTALLED) AC_SUBST(CGC_CAP_INSTALLED) AC_SUBST(MAIN_VARIANT) +AC_SUBST(INSTALL_SETUP_FLAGS) + mk_needed_dir() { if test ! -d "$1" ; then From 923ff555d982136f992145beeb9afbf1d12b7fdf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 May 2010 16:31:07 -0600 Subject: [PATCH 18/52] Fix problems with DESTDIR patching Merge to v5.0 --- collects/setup/unixstyle-install.rkt | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/collects/setup/unixstyle-install.rkt b/collects/setup/unixstyle-install.rkt index b702633824..0772afc224 100644 --- a/collects/setup/unixstyle-install.rkt +++ b/collects/setup/unixstyle-install.rkt @@ -12,10 +12,10 @@ ;; (interactive, undo-on-error, create-uninstaller) ;; - `copy': similar to `move', but copies instead of moving ;; - `make-install-copytree': copies some toplevel directories, skips ".*" -;; and "compiled" subdirs, and rewrites "config.ss", but no uninstaller +;; and "compiled" subdirs, and rewrites "config.rkt", but no uninstaller ;; (used by `make install') (requires an additional `origtree' argument) ;; - `make-install-destdir-fix': fixes paths in binaries, laucnhers, and -;; config.ss (used by `make install' to fix a DESTDIR) (requires exactly +;; config.rkt (used by `make install' to fix a DESTDIR) (requires exactly ;; the same args as `make-install-copytree' (prefixed) and requires a ;; DESTDIR setting) ;; * rktdir: The source racket directory @@ -180,7 +180,8 @@ (write-bytes buf (current-output-port) (cdadr m)))))) (let ([magic (with-input-from-file file (lambda () (read-bytes 10)))]) (cond [(or (regexp-match #rx#"^\177ELF" magic) - (regexp-match #rx#"^\316\372\355\376" magic)) + (regexp-match #rx#"^\316\372\355\376" magic) + (regexp-match #rx#"^\317\372\355\376" magic)) (let ([temp (format "~a-temp-for-install" (regexp-replace* #rx"/" file "_"))]) (with-handlers ([exn? (lambda (e) (delete-file temp) (raise e))]) @@ -194,12 +195,12 @@ (fix-script file)] [else (error (format "unknown executable: ~a" file))]))) -(define (fix-executables [binfiles #f]) - (parameterize ([current-directory (dir: 'bin)]) +(define (fix-executables bindir librktdir [binfiles #f]) + (parameterize ([current-directory bindir]) (for ([f (in-list (or binfiles (ls)))] #:when (file-exists? f)) (fix-executable f))) ;; fix the starter executable too - (parameterize ([current-directory (dir: 'librkt)]) + (parameterize ([current-directory librktdir]) (when (file-exists? "starter") (fix-executable "starter")))) ;; remove and record all empty dirs @@ -278,14 +279,14 @@ (apply make-path collectsdir "config" xs)) (define (ftime file) (and (file-exists? file) (file-or-directory-modify-seconds file))) - (let* ([src (cpath "config.ss")] - [zo (cpath "compiled" "config_ss.zo")] - ;; [dep (cpath "compiled" "config_ss.dep")] ; not needed + (let* ([src (cpath "config.rkt")] + [zo (cpath "compiled" "config_rkt.zo")] + ;; [dep (cpath "compiled" "config_rkt.dep")] ; not needed [src-time (ftime src)] [zo-time (ftime zo)]) (printf "Rewriting configuration file at: ~a...\n" src) (parameterize ([current-namespace base-ns] ; to compile (see above) - [current-library-collection-paths ; for configtab.ss + [current-library-collection-paths ; for configtab.rkt (list collectsdir)]) (with-output-to-file src #:exists 'truncate/replace (lambda () @@ -300,7 +301,7 @@ (printf " (define absolute-installation? #t))\n"))) ;; recompile & set times as if nothing happened (don't remove .dep) ;; this requires the file to look the same on all compilations, and - ;; configtab.ss generates bindings unhygienically for that reason. + ;; configtab.rkt generates bindings unhygienically for that reason. (when compile? (when src-time (file-or-directory-modify-seconds src src-time)) (if (not zo-time) @@ -405,7 +406,7 @@ (when (and move? (not (null? (ls)))) (error (format "leftovers in source tree: ~s" (ls)))) ;; we need to know which files need fixing - (fix-executables binfiles) + (fix-executables (dir: 'bin) (dir: 'librkt) binfiles) (write-uninstaller) (write-config)) (when move? @@ -433,6 +434,7 @@ (define origtree? (equal? "yes" (get-arg))) ;; grab paths before we change them (define bindir (dir: 'bin)) + (define librktdir (dir: 'librkt)) (define collectsdir (dir: 'collects)) (define (remove-dest p) (let ([pfx (and (< destdirlen (string-length p)) @@ -444,7 +446,7 @@ ;; no need to send an explicit binfiles argument -- this function is used ;; only when DESTDIR is present, so we're installing to a directory that ;; has only our binaries - (fix-executables) + (fix-executables bindir librktdir) (unless origtree? (write-config collectsdir))) ;; -------------------------------------------------------------------------- From 7442f14305251bf54749f14471032170aa38ec9b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 May 2010 17:05:33 -0600 Subject: [PATCH 19/52] fix problems with raco exe Merge to v5.0 --- collects/compiler/distribute.rkt | 4 +- collects/compiler/embed-unit.rkt | 49 +++++++++++++------ collects/setup/dirs.rkt | 2 +- collects/tests/racket/embed.rktl | 84 ++++++++++++++++---------------- 4 files changed, 78 insertions(+), 61 deletions(-) diff --git a/collects/compiler/distribute.rkt b/collects/compiler/distribute.rkt index e2e1a8f33c..26a178bf71 100644 --- a/collects/compiler/distribute.rkt +++ b/collects/compiler/distribute.rkt @@ -234,13 +234,13 @@ (build-path exe-dir dll))))) (define (copy-framework name 3m? lib-dir) - (let* ([fw-name (format "PLT_~a.framework" name)] + (let* ([fw-name (format "~a.framework" name)] [sub-dir (build-path fw-name "Versions" (if 3m? (format "~a_3m" (version)) (version)))]) (make-directory* (build-path lib-dir sub-dir)) - (let* ([fw-name (build-path sub-dir (format "PLT_~a" name))] + (let* ([fw-name (build-path sub-dir (format "~a" name))] [dll-dir (find-framework fw-name)]) (copy-file* (build-path dll-dir fw-name) (build-path lib-dir fw-name)) diff --git a/collects/compiler/embed-unit.rkt b/collects/compiler/embed-unit.rkt index 4a7de59766..01f4b4b59a 100644 --- a/collects/compiler/embed-unit.rkt +++ b/collects/compiler/embed-unit.rkt @@ -621,7 +621,10 @@ ;; Have a relative mapping? (let-values ([(a) (if rel-to (assq (resolved-module-path-name rel-to) mapping-table) - #f)]) + #f)] + [(ss->rkt) + (lambda (s) + (regexp-replace #rx"[.]ss$" s ".rkt"))]) (if a (let-values ([(a2) (assoc name (cadr a))]) (if a2 @@ -639,20 +642,20 @@ (if (null? (cddr name)) (if (regexp-match #rx"^[^/]*[.]" (cadr name)) ;; mzlib - (string-append "mzlib/" (cadr name)) + (string-append "mzlib/" (ss->rkt (cadr name))) ;; new-style (if (regexp-match #rx"^[^/.]*$" (cadr name)) - (string-append (cadr name) "/main.ss") + (string-append (cadr name) "/main.rkt") (if (regexp-match #rx"^[^.]*$" (cadr name)) ;; need a suffix: - (string-append (cadr name) ".ss") - (cadr name)))) + (string-append (cadr name) ".rkt") + (ss->rkt (cadr name))))) ;; old-style multi-string (string-append (apply string-append (map (lambda (s) (string-append s "/")) (cddr name))) - (cadr name))) + (ss->rkt (cadr name)))) (if (eq? 'planet (car name)) (if (null? (cddr name)) ;; need to normalize: @@ -673,7 +676,7 @@ (if (suffix-after . <= . 0) (if (regexp-match? #rx"[.]" s) s - (string-append s ".ss")) + (string-append s ".rkt")) s)))))] [(last-of) (lambda (l) @@ -689,8 +692,8 @@ (let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)]) (cons 'planet (cons (if (null? (cddr parts)) - "main.ss" - (last-of parts)) + "main.rkt" + (ss->rkt (last-of parts))) (cons (cons (car parts) @@ -743,6 +746,19 @@ ;; Let default handler try: (orig name rel-to stx load?))))))))))])]) (current-module-name-resolver embedded-resolver)))))) + + (define (ss<->rkt path) + (cond + [(regexp-match? #rx#"[.]ss$" path) + (ss<->rkt (path-replace-suffix path #".rkt"))] + [(regexp-match? #rx#"[.]rkt$" path) + (if (file-exists? path) + path + (let ([p2 (path-replace-suffix path #".ss")]) + (if (file-exists? path) + p2 + path)))] + [else path])) ;; Write a module bundle that can be loaded with 'load' (do not embed it ;; into an executable). The bundle is written to the current output port. @@ -757,7 +773,7 @@ (normalize f)))] [files (map resolve-one-path module-paths)] [collapse-one (lambda (mp) - (collapse-module-path mp (build-path (current-directory) "dummy.ss")))] + (collapse-module-path mp (build-path (current-directory) "dummy.rkt")))] [collapsed-mps (map collapse-one module-paths)] [prefix-mapping (map (lambda (f m) (cons f (let ([p (car m)]) @@ -811,7 +827,7 @@ (if (null? runtimes) #f (let* ([table-sym (module-path-index-resolve - (module-path-index-join '(lib "runtime-path-table.ss" "mzlib" "private") + (module-path-index-join '(lib "runtime-path-table.rkt" "mzlib" "private") #f))] [table-path (resolved-module-path-name table-sym)]) (assoc (normalize table-path) l)))]) @@ -887,14 +903,15 @@ p (let ([s (regexp-split #rx"/" (cadr p))]) (if (null? (cdr s)) - `(lib "main.ss" ,(cadr p)) + `(lib "main.rkt" ,(cadr p)) (let ([s (reverse s)]) `(lib ,(car s) ,@(reverse (cdr s))))))) p)]) - (build-path (if (null? (cddr p)) - (collection-path "mzlib") - (apply collection-path (cddr p))) - (cadr p)))] + (ss<->rkt + (build-path (if (null? (cddr p)) + (collection-path "mzlib") + (apply collection-path (cddr p))) + (cadr p))))] [else p])]) (and p (path->bytes diff --git a/collects/setup/dirs.rkt b/collects/setup/dirs.rkt index 050ecf143e..20c75e2c6e 100644 --- a/collects/setup/dirs.rkt +++ b/collects/setup/dirs.rkt @@ -180,7 +180,7 @@ (build-path dir r) r))) p)))] - [rel (get/set-dylib-path exe "PLT_M[rz]" #f)]) + [rel (get/set-dylib-path exe "Racket" #f)]) (cond [(not rel) #f] ; no framework reference found!? [(regexp-match diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 639fe36e10..19c392502d 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -103,10 +103,10 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "mzscheme"))) + `((#t (lib ,filename "tests" "racket"))) null #f - `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) + `(,(flags "l") ,(string-append "tests/racket/" filename))) (try-exe dest expect mred?) ;; Try explicit prefix: @@ -116,7 +116,7 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((,pfx (lib ,filename "tests" "mzscheme")) + `((,pfx (lib ,filename "tests" "racket")) (#t (lib "scheme/init"))) null #f @@ -133,7 +133,7 @@ ;; Try full path, and use literal S-exp to start (printf ">>>literal sexp\n") (prepare dest filename) - (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (let ([path (build-path (collection-path "tests" "racket") filename)]) (make-embedding-executable dest mred? #f `((#t ,path)) @@ -146,7 +146,7 @@ ;; Use `file' form: (printf ">>>file\n") (prepare dest filename) - (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (let ([path (build-path (collection-path "tests" "racket") filename)]) (make-embedding-executable dest mred? #f `((#t (file ,(path->string path)))) @@ -159,7 +159,7 @@ ;; Use relative path (printf ">>>relative path\n") (prepare dest filename) - (parameterize ([current-directory (collection-path "tests" "mzscheme")]) + (parameterize ([current-directory (collection-path "tests" "racket")]) (make-embedding-executable dest mred? #f `((#f ,filename)) @@ -174,13 +174,13 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "mzscheme")) - (#t (lib "embed-me3.ss" "tests" "mzscheme"))) + `((#t (lib ,filename "tests" "racket")) + (#t (lib "embed-me3.rkt" "tests" "racket"))) null (base-compile `(begin - (namespace-require '(lib "embed-me3.ss" "tests" "mzscheme")) - (namespace-require '(lib ,filename "tests" "mzscheme")))) + (namespace-require '(lib "embed-me3.rkt" "tests" "racket")) + (namespace-require '(lib ,filename "tests" "racket")))) `(,(flags ""))) (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) @@ -195,14 +195,14 @@ '(namespace-require ''#%kernel))))) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "mzscheme"))) + `((#t (lib ,filename "tests" "racket"))) (list tmp - (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) + (build-path (collection-path "tests" "racket") "embed-me4.rktl")) `(with-output-to-file "stdout" (lambda () (display "... and more!\n")) 'append) - `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) + `(,(flags "l") ,(string-append "tests/racket/" filename))) (delete-file tmp)) (try-exe dest (string-append "This is the literal expression 4.\n" @@ -210,12 +210,12 @@ expect) mred?))) - (one-mz-test "embed-me1.ss" "This is 1\n" #t) - (one-mz-test "embed-me1b.ss" "This is 1b\n" #f) - (one-mz-test "embed-me1c.ss" "This is 1c\n" #f) - (one-mz-test "embed-me1d.ss" "This is 1d\n" #f) - (one-mz-test "embed-me1e.ss" "This is 1e\n" #f) - (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n" #t) + (one-mz-test "embed-me1.rkt" "This is 1\n" #t) + (one-mz-test "embed-me1b.rkt" "This is 1b\n" #f) + (one-mz-test "embed-me1c.rkt" "This is 1c\n" #f) + (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f) + (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f) + (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) ;; Try unicode expr and cmdline: (prepare dest "unicode") @@ -238,13 +238,13 @@ (mz-tests #t) (begin - (prepare mr-dest "embed-me5.ss") + (prepare mr-dest "embed-me5.rkt") (make-embedding-executable mr-dest #t #f - `((#t (lib "embed-me5.ss" "tests" "mzscheme"))) + `((#t (lib "embed-me5.rkt" "tests" "racket"))) null #f - `("-l" "tests/mzscheme/embed-me5.ss")) + `("-l" "tests/racket/embed-me5.rkt")) (try-exe mr-dest "This is 5: #\n" #t)) ;; Try the mzc interface: @@ -260,15 +260,15 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me1.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) - ;; Check that etc.ss isn't found if it's not included: + ;; Check that etc.rkt isn't found if it's not included: (printf ">>not included\n") (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) ;; And it is found if it is included: @@ -276,8 +276,8 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - "++lib" "mzlib/etc.ss" - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + "++lib" "mzlib/etc.rkt" + (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) ;; Or, it's found if we set the collection path: @@ -287,7 +287,7 @@ (path->string (mk-dest mred?)) "--collects-path" (path->string (find-collects-dir)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) ;; Don't try a distribution for this one: (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) @@ -296,10 +296,10 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - "++lib" "mzlib/etc.ss" + "++lib" "mzlib/etc.rkt" "--collects-dest" "cts" "--collects-path" "cts" - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") (test #f system* (mk-dest mred?)) @@ -326,17 +326,17 @@ (system-library-subpath))) (define ext-file - (build-path ext-dir (append-extension-suffix "embed-me8_ss"))) + (build-path ext-dir (append-extension-suffix "embed-me8_rkt"))) (define ss-file - (build-path (find-system-path 'temp-dir) "embed-me9.ss")) + (build-path (find-system-path 'temp-dir) "embed-me9.rkt")) (make-directory* ext-dir) (system* mzc "--cc" "-d" (path->string (path-only obj-file)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me8.c"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me8.c"))) (system* mzc "--ld" (path->string ext-file) @@ -344,7 +344,7 @@ (when (file-exists? ss-file) (delete-file ss-file)) - (copy-file (build-path (collection-path "tests" "mzscheme") "embed-me9.ss") + (copy-file (build-path (collection-path "tests" "racket") "embed-me9.rkt") ss-file) (system* mzc @@ -361,7 +361,7 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me10.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me10.rkt"))) (try-exe (mk-dest mred?) "#t\n" mred?))) (extension-test #f) @@ -372,7 +372,7 @@ (system* mzc "--gui-exe" (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) (try-exe (mk-dest #t) "This is 5: #\n" #t)) ;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: @@ -382,34 +382,34 @@ (test #t system* (build-path (find-console-bin-dir) "mred") "-qu" - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss")) + (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")) (path->string direct)) (system* mzc "--gui-exe" (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))) (try-exe (mk-dest #t) "plotted\n" #t)) ;; Try including source that needs a reader extension (define (try-reader-test mred?) (define dest (mk-dest mred?)) - (define filename "embed-me11.ss") + (define filename "embed-me11.rkt") (define (flags s) (string-append "-" s)) (create-embedding-executable dest - #:modules `((#t (lib ,filename "tests" "mzscheme"))) - #:cmdline `(,(flags "l") ,(string-append "tests/mzscheme/" filename)) + #:modules `((#t (lib ,filename "tests" "racket"))) + #:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename)) #:src-filter (lambda (f) (let-values ([(base name dir?) (split-path f)]) (equal? name (string->path filename)))) #:get-extra-imports (lambda (f code) (let-values ([(base name dir?) (split-path f)]) (if (equal? name (string->path filename)) - '((lib "embed-me11-rd.ss" "tests" "mzscheme")) + '((lib "embed-me11-rd.rkt" "tests" "racket")) null))) #:mred? mred?) From 23f30af459b4157c87b62dff535cdd0b7eb46927 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 26 May 2010 18:08:40 -0400 Subject: [PATCH 20/52] Rewrote do: to expand into do. --- collects/typed-scheme/private/prims.rkt | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index a0bac01d3d..be310b68e4 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -368,15 +368,15 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (do: stx) (syntax-parse stx #:literals (:) [(_ : ty - ((var:annotated-name init (~optional step:expr #:defaults ([step #'var]))) ...) - (stop?:expr (~optional (~seq finish0:expr finish:expr ...) #:defaults ([finish0 #'(void)] [(finish 1) '()]))) + ((var:annotated-name rest ...) ...) + (stop?:expr ret ...) c:expr ...) (syntax/loc stx - (let: doloop : ty ([var.name : var.ty init] ...) - (if stop? - (begin finish0 finish ...) - (begin c ... (doloop step ...)))))])) + (ann (do ((var.ann-name rest ...) ...) + (stop? ret ...) + c ...) + ty))])) (define-syntax (provide: stx) (syntax-parse stx From 5213f54f56e6d9d1a14b16fd0348495a20a648e9 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 26 May 2010 17:24:31 -0400 Subject: [PATCH 21/52] Added the for:, for/list:, etc macros. --- collects/typed-scheme/private/for-clauses.rkt | 17 ++++++++++ collects/typed-scheme/private/prims.rkt | 32 ++++++++++++++++++- 2 files changed, 48 insertions(+), 1 deletion(-) create mode 100644 collects/typed-scheme/private/for-clauses.rkt diff --git a/collects/typed-scheme/private/for-clauses.rkt b/collects/typed-scheme/private/for-clauses.rkt new file mode 100644 index 0000000000..946a6020f9 --- /dev/null +++ b/collects/typed-scheme/private/for-clauses.rkt @@ -0,0 +1,17 @@ +#lang scheme/base + +(require syntax/parse + "annotate-classes.rkt") + +(provide for-clause) + +(define-splicing-syntax-class for-clause + ;; single-valued seq-expr + (pattern (var:annotated-name seq-expr:expr) + #:with (expand ...) (list #'(var.ann-name seq-expr))) + ;; multi-valued seq-expr + (pattern ((var:annotated-name ...) seq-expr:expr) + #:with (expand ...) (list #'((var.ann-name ...) seq-expr))) + ;; when clause + (pattern (~seq #:when guard:expr) + #:with (expand ...) (list #'#:when #'guard))) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index be310b68e4..71c632d711 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -39,7 +39,8 @@ This file defines two sorts of primitives. All of them are provided into any mod (private internal) (except-in (utils utils tc-utils)) (env type-name-env) - "type-contract.rkt")) + "type-contract.rkt" + "for-clauses.rkt")) (require (utils require-contract) "colon.rkt" @@ -378,6 +379,35 @@ This file defines two sorts of primitives. All of them are provided into any mod c ...) ty))])) +(define-for-syntax (define-for-variant name) + (lambda (stx) + (syntax-parse stx #:literals (:) + [(_ : ty + (clause:for-clause ...) + c:expr ...) + (quasisyntax/loc + stx + (ann (#,name + (clause.expand ... ...) + c ...) + ty))]))) +(define-syntax (define-for-variants stx) + (syntax-parse stx + [(_ (name untyped-name) ...) + (quasisyntax/loc + stx + (begin (define-syntax name (define-for-variant #'untyped-name)) ...))])) +(define-for-variants + (for: for) + (for/list: for/list) + (for/hash: for/hash) + (for/hasheq: for/hasheq) + (for/hasheqv: for/hasheqv) + (for/and: for/and) + (for/or: for/or) + (for/first: for/first) + (for/last: for/last)) + (define-syntax (provide: stx) (syntax-parse stx [(_ [i:id t] ...) From 664ef2c0a3bb478634591b596f2473f249095e4f Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 24 May 2010 17:58:58 -0400 Subject: [PATCH 22/52] Extended the type signatures of bitwise operations to be closed on naturals. --- collects/typed-scheme/private/base-env.rkt | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index f3fe608186..db91883da6 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -422,13 +422,19 @@ [match:error ((list) Univ . ->* . (Un))] -[arithmetic-shift (-Integer -Integer . -> . -Integer)] -[bitwise-and (null -Integer . ->* . -Integer)] -[bitwise-ior (null -Integer . ->* . -Integer)] -[bitwise-not (null -Integer . ->* . -Integer)] -[bitwise-xor (null -Integer . ->* . -Integer)] +[arithmetic-shift (cl->* (-Nat -Nat . -> . -Nat) + (-Integer -Integer . -> . -Integer))] +[bitwise-and (cl->* (null -Nat . ->* . -Nat) + (null -Integer . ->* . -Integer))] +[bitwise-ior (cl->* (null -Nat . ->* . -Nat) + (null -Integer . ->* . -Integer))] +[bitwise-not (cl->* (null -Nat . ->* . -Nat) + (null -Integer . ->* . -Integer))] +[bitwise-xor (cl->* (null -Nat . ->* . -Nat) + (null -Integer . ->* . -Integer))] -[abs (-Real . -> . -Real)] +[abs (cl->* (-Integer . -> . -Nat) + (-Real . -> . -Real))] [file-exists? (-Pathlike . -> . B)] [string->symbol (-String . -> . Sym)] From 762f108c04b78f14d851b6b93b5bf0c873658399 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 21 May 2010 10:59:50 -0400 Subject: [PATCH 23/52] Fixed a bug in typed Scheme's optimizer when using binary arithmetic operators in a unary fashion with floats. --- collects/typed-scheme/private/optimize.rkt | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 5542553e5f..ed63d73741 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -60,11 +60,11 @@ (begin (log-optimization "unary float" #'op) #'(op.unsafe f.opt))) ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments - (pattern (#%plain-app op:float-binary-op f fs ...) + (pattern (#%plain-app op:float-binary-op f1 f2 fs ...) #:with opt (begin (log-optimization "binary float" #'op) - (for/fold ([o #'f.opt]) - ([e (syntax->list #'(fs.opt ...))]) + (for/fold ([o #'f1.opt]) + ([e (syntax->list #'(f2.opt fs.opt ...))]) #`(op.unsafe #,o #,e)))) (pattern (#%plain-app op:pair-unary-op p) #:with opt @@ -99,10 +99,10 @@ #:exists 'append) (current-output-port)))) (begin0 - (parameterize ([current-output-port port]) - (syntax-parse stx #:literal-sets (kernel-literals) - [e:opt-expr - (syntax/loc stx e.opt)])) + (parameterize ([current-output-port port]) + (syntax-parse stx #:literal-sets (kernel-literals) + [e:opt-expr + (syntax/loc stx e.opt)])) (if (and *log-optimizations?* *log-optimizatons-to-log-file?*) (close-output-port port) From e3b994abfffb0ebc3a5460a0a8730441875ebbb1 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 21 May 2010 17:53:43 -0400 Subject: [PATCH 24/52] Typed Scheme's optimizer now recognizes specialized (safe) float operations. --- collects/typed-scheme/private/optimize.rkt | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index ed63d73741..8e7358ea55 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require syntax/parse (for-template scheme/base scheme/unsafe/ops) +(require syntax/parse (for-template scheme/base scheme/flonum scheme/unsafe/ops) "../utils/utils.rkt" unstable/match scheme/match unstable/syntax (rep type-rep) (types abbrev type-table utils)) @@ -13,14 +13,20 @@ #:with opt #'e.opt)) (define-syntax-class float-binary-op - #:literals (+ - * / = <= < > >= min max) + #:literals (+ - * / = <= < > >= min max + fl+ fl- fl* fl/ fl= fl<= fl< fl> fl>= flmin flmax) (pattern (~and i:id (~or + - * / = <= < > >= min max)) - #:with unsafe (format-id #'here "unsafe-fl~a" #'i))) + #:with unsafe (format-id #'here "unsafe-fl~a" #'i)) + (pattern (~and i:id (~or fl+ fl- fl* fl/ fl= fl<= fl< fl> fl>= flmin flmax)) + #:with unsafe (format-id #'here "unsafe-~a" #'i))) (define-syntax-class float-unary-op - #:literals (abs sin cos tan asin acos atan log exp) - (pattern (~and i:id (~or abs sin cos tan asin acos atan log exp)) - #:with unsafe (format-id #'here "unsafe-fl~a" #'i))) + #:literals (abs sin cos tan asin acos atan log exp sqrt round floor ceiling truncate + flabs flsin flcos fltan flasin flacos flatan fllog flexp flsqrt flround flfloor flceiling fltruncate) + (pattern (~and i:id (~or abs sin cos tan asin acos atan log exp sqrt round floor ceiling truncate)) + #:with unsafe (format-id #'here "unsafe-fl~a" #'i)) + (pattern (~and i:id (~or flabs flsin flcos fltan flasin flacos flatan fllog flexp flsqrt flround flfloor flceiling fltruncate)) + #:with unsafe (format-id #'here "unsafe-~a" #'i))) (define-syntax-class pair-opt-expr (pattern e:opt-expr From 61f6a2579bf6ffc7f3d09cf96d2b31fb5b97c22d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 21 May 2010 11:01:17 -0400 Subject: [PATCH 25/52] Documented the typed benchmarks. --- collects/tests/racket/benchmarks/common/README.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/tests/racket/benchmarks/common/README.txt b/collects/tests/racket/benchmarks/common/README.txt index d1aa68dc7f..b9e027ca97 100644 --- a/collects/tests/racket/benchmarks/common/README.txt +++ b/collects/tests/racket/benchmarks/common/README.txt @@ -36,6 +36,9 @@ Most bechmarks were obtained from Files that end in ".sch" are supposed to be standard Scheme plus `time'. Files that end in ".rkt" are Racket wrapper modules or helper scripts. +Files that end in "-typed.rktl" are Typed Scheme versions of the benchmarks. +Files that end in "-[non-]optimizing.rkt" are Typed Scheme wrappers +that turn Typed Scheme's optimizer on or off. To build .sch directly with Gambit, Bigloo, or Chicken: racket -f mk-gambit.rktl ; gsi -:m10000 .o1 From ca9e35b9be02b0a99ced489eb6d91aa2e24096d3 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 20 May 2010 10:41:02 -0400 Subject: [PATCH 26/52] Changed some of the benchmarks to run for more iterations. --- .../tests/racket/benchmarks/common/cpstack-typed.rktl | 8 +++++++- collects/tests/racket/benchmarks/common/cpstack.sch | 7 ++++++- .../tests/racket/benchmarks/common/ctak-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/ctak.sch | 2 +- .../tests/racket/benchmarks/common/dderiv-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/dderiv.sch | 2 +- .../tests/racket/benchmarks/common/deriv-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/deriv.sch | 2 +- .../tests/racket/benchmarks/common/div-typed.rktl | 4 ++-- collects/tests/racket/benchmarks/common/div.sch | 2 +- .../tests/racket/benchmarks/common/fft-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/fft.sch | 2 +- .../tests/racket/benchmarks/common/graphs-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/graphs.sch | 2 +- .../racket/benchmarks/common/lattice2-typed.rktl | 6 +++++- collects/tests/racket/benchmarks/common/lattice2.sch | 6 +++++- .../tests/racket/benchmarks/common/mazefun-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/mazefun.sch | 2 +- .../racket/benchmarks/common/nestedloop-typed.rktl | 10 +++++++--- .../tests/racket/benchmarks/common/nestedloop.sch | 11 +++++++---- .../tests/racket/benchmarks/common/nfa-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/nfa.sch | 2 +- .../tests/racket/benchmarks/common/nqueens-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/nqueens.sch | 2 +- .../racket/benchmarks/common/paraffins-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/paraffins.sch | 2 +- .../tests/racket/benchmarks/common/puzzle-typed.rktl | 8 +++++--- collects/tests/racket/benchmarks/common/puzzle.sch | 8 +++++--- .../tests/racket/benchmarks/common/tak-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/tak.sch | 2 +- .../tests/racket/benchmarks/common/takl-typed.rktl | 9 +++++++-- collects/tests/racket/benchmarks/common/takl.sch | 8 ++++++-- .../tests/racket/benchmarks/common/takr-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/takr.sch | 2 +- .../tests/racket/benchmarks/common/takr2-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/takr2.sch | 2 +- .../racket/benchmarks/common/triangle-typed.rktl | 2 +- collects/tests/racket/benchmarks/common/triangle.sch | 2 +- 38 files changed, 89 insertions(+), 50 deletions(-) diff --git a/collects/tests/racket/benchmarks/common/cpstack-typed.rktl b/collects/tests/racket/benchmarks/common/cpstack-typed.rktl index 2de0f2587e..3637c86de3 100644 --- a/collects/tests/racket/benchmarks/common/cpstack-typed.rktl +++ b/collects/tests/racket/benchmarks/common/cpstack-typed.rktl @@ -34,4 +34,10 @@ ;;; call: (cpstak 18 12 6) -(time (cpstak 18 12 2)) +(let ((input (with-input-from-file "input.txt" read))) + (time (let: loop : Integer + ((n : Integer 20) (v : Integer 0)) + (if (zero? n) + v + (loop (- n 1) + (cpstak 18 12 (if input 2 0))))))) diff --git a/collects/tests/racket/benchmarks/common/cpstack.sch b/collects/tests/racket/benchmarks/common/cpstack.sch index 6ef109b859..a1af660c60 100644 --- a/collects/tests/racket/benchmarks/common/cpstack.sch +++ b/collects/tests/racket/benchmarks/common/cpstack.sch @@ -31,4 +31,9 @@ ;;; call: (cpstak 18 12 6) -(time (cpstak 18 12 2)) +(let ((input (with-input-from-file "input.txt" read))) + (time (let loop ((n 20) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (cpstak 18 12 (if input 2 0))))))) diff --git a/collects/tests/racket/benchmarks/common/ctak-typed.rktl b/collects/tests/racket/benchmarks/common/ctak-typed.rktl index 0cc47a9104..d04e765808 100644 --- a/collects/tests/racket/benchmarks/common/ctak-typed.rktl +++ b/collects/tests/racket/benchmarks/common/ctak-typed.rktl @@ -58,7 +58,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time (let: loop : Integer - ((n : Integer 8) (v : Integer 0)) + ((n : Integer 25) (v : Integer 0)) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/ctak.sch b/collects/tests/racket/benchmarks/common/ctak.sch index f6c6cbc159..30264d86b9 100644 --- a/collects/tests/racket/benchmarks/common/ctak.sch +++ b/collects/tests/racket/benchmarks/common/ctak.sch @@ -53,7 +53,7 @@ ;;; call: (ctak 18 12 6) (let ((input (with-input-from-file "input.txt" read))) - (time (let loop ((n 8) (v 0)) + (time (let loop ((n 25) (v 0)) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/dderiv-typed.rktl b/collects/tests/racket/benchmarks/common/dderiv-typed.rktl index ea45247791..2460a6731d 100644 --- a/collects/tests/racket/benchmarks/common/dderiv-typed.rktl +++ b/collects/tests/racket/benchmarks/common/dderiv-typed.rktl @@ -95,7 +95,7 @@ (: run ( -> Void)) (define (run) (do ((i 0 (+ i 1))) - ((= i 50000)) + ((= i 1000000)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) diff --git a/collects/tests/racket/benchmarks/common/dderiv.sch b/collects/tests/racket/benchmarks/common/dderiv.sch index 5e47a0b037..a3303809bb 100644 --- a/collects/tests/racket/benchmarks/common/dderiv.sch +++ b/collects/tests/racket/benchmarks/common/dderiv.sch @@ -75,7 +75,7 @@ (define (run) (do ((i 0 (+ i 1))) - ((= i 50000)) + ((= i 1000000)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) diff --git a/collects/tests/racket/benchmarks/common/deriv-typed.rktl b/collects/tests/racket/benchmarks/common/deriv-typed.rktl index a2516a07fd..80dc531e6d 100644 --- a/collects/tests/racket/benchmarks/common/deriv-typed.rktl +++ b/collects/tests/racket/benchmarks/common/deriv-typed.rktl @@ -56,7 +56,7 @@ (: run ( -> Void)) (define (run) (do ((i 0 (+ i 1))) - ((= i 50000)) + ((= i 1000000)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) diff --git a/collects/tests/racket/benchmarks/common/deriv.sch b/collects/tests/racket/benchmarks/common/deriv.sch index 74881b469c..ad0ab6ec8b 100644 --- a/collects/tests/racket/benchmarks/common/deriv.sch +++ b/collects/tests/racket/benchmarks/common/deriv.sch @@ -46,7 +46,7 @@ (define (run) (do ((i 0 (+ i 1))) - ((= i 50000)) + ((= i 1000000)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) diff --git a/collects/tests/racket/benchmarks/common/div-typed.rktl b/collects/tests/racket/benchmarks/common/div-typed.rktl index 20cf415ed5..4317858b2d 100644 --- a/collects/tests/racket/benchmarks/common/div-typed.rktl +++ b/collects/tests/racket/benchmarks/common/div-typed.rktl @@ -57,8 +57,8 @@ ;;; for the recursive test call: (test-2 *ll*) (let ((input (with-input-from-file "input.txt" read))) - (time (let: loop : (U Integer (Listof Any)) - ((n : Integer 10) (v : (U Integer (Listof Any)) 0)) + (time (let: loop : (Pair Void Void) + ((n : Integer 200) (v : (U Integer (Listof Any)) 0)) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/div.sch b/collects/tests/racket/benchmarks/common/div.sch index cbdaeb0850..699eaac6b5 100644 --- a/collects/tests/racket/benchmarks/common/div.sch +++ b/collects/tests/racket/benchmarks/common/div.sch @@ -48,7 +48,7 @@ ;;; for the recursive test call: (test-2 *ll*) (let ((input (with-input-from-file "input.txt" read))) - (time (let loop ((n 10) (v 0)) + (time (let loop ((n 200) (v 0)) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/fft-typed.rktl b/collects/tests/racket/benchmarks/common/fft-typed.rktl index ebecbf2b58..4477ece38b 100644 --- a/collects/tests/racket/benchmarks/common/fft-typed.rktl +++ b/collects/tests/racket/benchmarks/common/fft-typed.rktl @@ -119,7 +119,7 @@ (define (fft-bench) (do: : Null ((ntimes : Integer 0 (+ ntimes 1))) - ((= ntimes 1000) '()) + ((= ntimes 5000) '()) (fft *re* *im*))) ;;; call: (fft-bench) diff --git a/collects/tests/racket/benchmarks/common/fft.sch b/collects/tests/racket/benchmarks/common/fft.sch index 2ede72878a..ae63c90291 100644 --- a/collects/tests/racket/benchmarks/common/fft.sch +++ b/collects/tests/racket/benchmarks/common/fft.sch @@ -110,7 +110,7 @@ (define (fft-bench) (do ((ntimes 0 (+ ntimes 1))) - ((= ntimes 1000)) + ((= ntimes 5000)) (fft *re* *im*))) ;;; call: (fft-bench) diff --git a/collects/tests/racket/benchmarks/common/graphs-typed.rktl b/collects/tests/racket/benchmarks/common/graphs-typed.rktl index d847daed83..9d566562e6 100644 --- a/collects/tests/racket/benchmarks/common/graphs-typed.rktl +++ b/collects/tests/racket/benchmarks/common/graphs-typed.rktl @@ -709,7 +709,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time (let: loop : (Listof RDG) - ((n : Integer 3) (v : (Listof RDG) '())) + ((n : Integer 45) (v : (Listof RDG) '())) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/graphs.sch b/collects/tests/racket/benchmarks/common/graphs.sch index 1d8b8f43e7..50257f04cd 100644 --- a/collects/tests/racket/benchmarks/common/graphs.sch +++ b/collects/tests/racket/benchmarks/common/graphs.sch @@ -638,7 +638,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 3) (v 0)) + (let loop ((n 45) (v 0)) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/lattice2-typed.rktl b/collects/tests/racket/benchmarks/common/lattice2-typed.rktl index fe53429bc3..86f9c21863 100644 --- a/collects/tests/racket/benchmarks/common/lattice2-typed.rktl +++ b/collects/tests/racket/benchmarks/common/lattice2-typed.rktl @@ -231,4 +231,8 @@ (count-maps l3 l2) (count-maps l4 l4))) -(time (run)) +(time (let: loop : Integer ((n : Integer 3) (v : Integer 0)) + (if (zero? n) + v + (loop (- n 1) + (run))))) diff --git a/collects/tests/racket/benchmarks/common/lattice2.sch b/collects/tests/racket/benchmarks/common/lattice2.sch index 482ed6788c..a42072a371 100644 --- a/collects/tests/racket/benchmarks/common/lattice2.sch +++ b/collects/tests/racket/benchmarks/common/lattice2.sch @@ -202,4 +202,8 @@ (count-maps l3 l2) (count-maps l4 l4))) -(time (run)) +(time (let loop ((n 3) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (run))))) diff --git a/collects/tests/racket/benchmarks/common/mazefun-typed.rktl b/collects/tests/racket/benchmarks/common/mazefun-typed.rktl index f01610dbb1..7c5c91b555 100644 --- a/collects/tests/racket/benchmarks/common/mazefun-typed.rktl +++ b/collects/tests/racket/benchmarks/common/mazefun-typed.rktl @@ -237,7 +237,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time (let: loop : (U (Matrix (U '_ '*)) 'error) - ((n : Integer 500) (v : (U (Matrix (U '_ '*)) 'error) '())) + ((n : Integer 10000) (v : (U (Matrix (U '_ '*)) 'error) '())) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/mazefun.sch b/collects/tests/racket/benchmarks/common/mazefun.sch index bec2f56e67..cf169207eb 100644 --- a/collects/tests/racket/benchmarks/common/mazefun.sch +++ b/collects/tests/racket/benchmarks/common/mazefun.sch @@ -199,7 +199,7 @@ (let ((input (with-input-from-file "input.txt" read))) - (time (let loop ((n 500) (v 0)) + (time (let loop ((n 10000) (v 0)) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/nestedloop-typed.rktl b/collects/tests/racket/benchmarks/common/nestedloop-typed.rktl index b2061b310e..517265b20c 100644 --- a/collects/tests/racket/benchmarks/common/nestedloop-typed.rktl +++ b/collects/tests/racket/benchmarks/common/nestedloop-typed.rktl @@ -59,6 +59,10 @@ (loop6 (+ i6 1) (+ result 1))))))))))))))) (let ((cnt (if (with-input-from-file "input.txt" read) 18 1))) - (time (list - (loops cnt) - (func-loops cnt)))) + (time (let: loop : (Listof Integer) ((n : Integer 20) (v : (Listof Integer) '())) + (if (zero? n) + v + (loop (- n 1) + (list + (loops cnt) + (func-loops cnt))))))) diff --git a/collects/tests/racket/benchmarks/common/nestedloop.sch b/collects/tests/racket/benchmarks/common/nestedloop.sch index 64c6c0569c..0bb44fc58b 100644 --- a/collects/tests/racket/benchmarks/common/nestedloop.sch +++ b/collects/tests/racket/benchmarks/common/nestedloop.sch @@ -58,7 +58,10 @@ (loop6 (+ i6 1) (+ result 1))))))))))))))) (let ((cnt (if (with-input-from-file "input.txt" read) 18 1))) - (time (list - (loops cnt) - (func-loops cnt)))) - + (time (let loop ((n 20) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (list + (loops cnt) + (func-loops cnt))))))) diff --git a/collects/tests/racket/benchmarks/common/nfa-typed.rktl b/collects/tests/racket/benchmarks/common/nfa-typed.rktl index 527d470349..198d3e6441 100644 --- a/collects/tests/racket/benchmarks/common/nfa-typed.rktl +++ b/collects/tests/racket/benchmarks/common/nfa-typed.rktl @@ -50,7 +50,7 @@ 'fail)) (time (let ((input (string->list (string-append (make-string 133 #\a) "bc")))) - (let: loop : 'done ((n : Integer 150000)) + (let: loop : 'done ((n : Integer 2000000)) (if (zero? n) 'done (begin diff --git a/collects/tests/racket/benchmarks/common/nfa.sch b/collects/tests/racket/benchmarks/common/nfa.sch index b00dcd076b..bc28343c98 100644 --- a/collects/tests/racket/benchmarks/common/nfa.sch +++ b/collects/tests/racket/benchmarks/common/nfa.sch @@ -42,7 +42,7 @@ 'fail)) (time (let ((input (string->list (string-append (make-string 133 #\a) "bc")))) - (let loop ((n 150000)) + (let loop ((n 2000000)) (if (zero? n) 'done (begin diff --git a/collects/tests/racket/benchmarks/common/nqueens-typed.rktl b/collects/tests/racket/benchmarks/common/nqueens-typed.rktl index b6741da3f7..577dcd576c 100644 --- a/collects/tests/racket/benchmarks/common/nqueens-typed.rktl +++ b/collects/tests/racket/benchmarks/common/nqueens-typed.rktl @@ -37,7 +37,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let: loop : Integer ((n : Integer 500) (v : Integer 0)) + (let: loop : Integer ((n : Integer 10000) (v : Integer 0)) (if (zero? n) v (loop (- n 1) (nqueens (if input 8 0))))))) diff --git a/collects/tests/racket/benchmarks/common/nqueens.sch b/collects/tests/racket/benchmarks/common/nqueens.sch index e12d6904da..dcaea26372 100644 --- a/collects/tests/racket/benchmarks/common/nqueens.sch +++ b/collects/tests/racket/benchmarks/common/nqueens.sch @@ -31,7 +31,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 500) (v 0)) + (let loop ((n 10000) (v 0)) (if (zero? n) v (loop (- n 1) (nqueens (if input 8 0))))))) diff --git a/collects/tests/racket/benchmarks/common/paraffins-typed.rktl b/collects/tests/racket/benchmarks/common/paraffins-typed.rktl index 70161b6e23..bfa3d15b54 100644 --- a/collects/tests/racket/benchmarks/common/paraffins-typed.rktl +++ b/collects/tests/racket/benchmarks/common/paraffins-typed.rktl @@ -189,7 +189,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time (let: loop : Integer - ((n : Integer 100) (v : Integer 0)) + ((n : Integer 4000) (v : Integer 0)) (if (zero? n) v (loop (- n 1) (nb (if input 17 0))))))) diff --git a/collects/tests/racket/benchmarks/common/paraffins.sch b/collects/tests/racket/benchmarks/common/paraffins.sch index 708a85adcc..fbaf734bfb 100644 --- a/collects/tests/racket/benchmarks/common/paraffins.sch +++ b/collects/tests/racket/benchmarks/common/paraffins.sch @@ -169,7 +169,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 100) (v 0)) + (let loop ((n 4000) (v 0)) (if (zero? n) v (loop (- n 1) (nb (if input 17 0))))))) diff --git a/collects/tests/racket/benchmarks/common/puzzle-typed.rktl b/collects/tests/racket/benchmarks/common/puzzle-typed.rktl index d667ed50d0..1addc1b3e3 100644 --- a/collects/tests/racket/benchmarks/common/puzzle-typed.rktl +++ b/collects/tests/racket/benchmarks/common/puzzle-typed.rktl @@ -192,6 +192,8 @@ ;;; call: (start) -(time (start)) - - +(time (let: loop : Void ((n : Integer 50) (v : Void (void))) + (if (zero? n) + v + (loop (- n 1) + (start))))) diff --git a/collects/tests/racket/benchmarks/common/puzzle.sch b/collects/tests/racket/benchmarks/common/puzzle.sch index 47cbc60208..7cf1563d2b 100644 --- a/collects/tests/racket/benchmarks/common/puzzle.sch +++ b/collects/tests/racket/benchmarks/common/puzzle.sch @@ -165,6 +165,8 @@ ;;; call: (start) -(time (start)) - - +(time (let loop ((n 50) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (start))))) diff --git a/collects/tests/racket/benchmarks/common/tak-typed.rktl b/collects/tests/racket/benchmarks/common/tak-typed.rktl index 3b68854990..ba43e97563 100644 --- a/collects/tests/racket/benchmarks/common/tak-typed.rktl +++ b/collects/tests/racket/benchmarks/common/tak-typed.rktl @@ -24,7 +24,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let: loop : Integer ((n : Integer 500) (v : Integer 0)) + (let: loop : Integer ((n : Integer 15000) (v : Integer 0)) (if (zero? n) v (loop (- n 1) (tak 18 12 (if input 6 0))))))) diff --git a/collects/tests/racket/benchmarks/common/tak.sch b/collects/tests/racket/benchmarks/common/tak.sch index a795edcea0..69f8370fe1 100644 --- a/collects/tests/racket/benchmarks/common/tak.sch +++ b/collects/tests/racket/benchmarks/common/tak.sch @@ -22,7 +22,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 500) (v 0)) + (let loop ((n 15000) (v 0)) (if (zero? n) v (loop (- n 1) (tak 18 12 (if input 6 0))))))) diff --git a/collects/tests/racket/benchmarks/common/takl-typed.rktl b/collects/tests/racket/benchmarks/common/takl-typed.rktl index 31248b3c5b..0589d8e669 100644 --- a/collects/tests/racket/benchmarks/common/takl-typed.rktl +++ b/collects/tests/racket/benchmarks/common/takl-typed.rktl @@ -43,5 +43,10 @@ ;;; call: (mas 18l 12l 6l) -(let ((v (if (with-input-from-file "input.txt" read) l6l '()))) - (time (mas l18l l12l v))) +(let ((x (if (with-input-from-file "input.txt" read) l6l '()))) + (time (let: loop : (Listof Integer) + ((n : Integer 20) (v : (Listof Integer) '())) + (if (zero? n) + v + (loop (- n 1) + (mas l18l l12l x)))))) diff --git a/collects/tests/racket/benchmarks/common/takl.sch b/collects/tests/racket/benchmarks/common/takl.sch index 79df0c0af6..b052e75e53 100644 --- a/collects/tests/racket/benchmarks/common/takl.sch +++ b/collects/tests/racket/benchmarks/common/takl.sch @@ -39,5 +39,9 @@ ;;; call: (mas 18l 12l 6l) -(let ((v (if (with-input-from-file "input.txt" read) l6l '()))) - (time (mas l18l l12l v))) +(let ((x (if (with-input-from-file "input.txt" read) l6l '()))) + (time (let loop ((n 20) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (mas l18l l12l x)))))) diff --git a/collects/tests/racket/benchmarks/common/takr-typed.rktl b/collects/tests/racket/benchmarks/common/takr-typed.rktl index 5cc264a035..2a582ae832 100644 --- a/collects/tests/racket/benchmarks/common/takr-typed.rktl +++ b/collects/tests/racket/benchmarks/common/takr-typed.rktl @@ -619,7 +619,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let: loop : Integer ((n : Integer 500) (v : Integer 0)) + (let: loop : Integer ((n : Integer 1500) (v : Integer 0)) (if (zero? n) v (loop (- n 1) (tak0 18 12 (if input 6 0))))))) diff --git a/collects/tests/racket/benchmarks/common/takr.sch b/collects/tests/racket/benchmarks/common/takr.sch index ef46d38794..fd8406e861 100644 --- a/collects/tests/racket/benchmarks/common/takr.sch +++ b/collects/tests/racket/benchmarks/common/takr.sch @@ -519,7 +519,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 500) (v 0)) + (let loop ((n 1500) (v 0)) (if (zero? n) v (loop (- n 1) (tak0 18 12 (if input 6 0))))))) diff --git a/collects/tests/racket/benchmarks/common/takr2-typed.rktl b/collects/tests/racket/benchmarks/common/takr2-typed.rktl index da7fa8440d..fc4dcf6066 100644 --- a/collects/tests/racket/benchmarks/common/takr2-typed.rktl +++ b/collects/tests/racket/benchmarks/common/takr2-typed.rktl @@ -623,7 +623,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let: loop : Integer ((n : Integer 500) (v : Integer 0)) + (let: loop : Integer ((n : Integer 1500) (v : Integer 0)) (if (zero? n) v (loop (- n 1) (tak 18 12 (if input 6 0))))))) diff --git a/collects/tests/racket/benchmarks/common/takr2.sch b/collects/tests/racket/benchmarks/common/takr2.sch index c6deb8dc01..35c98244d4 100644 --- a/collects/tests/racket/benchmarks/common/takr2.sch +++ b/collects/tests/racket/benchmarks/common/takr2.sch @@ -522,7 +522,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 500) (v 0)) + (let loop ((n 1500) (v 0)) (if (zero? n) v (loop (- n 1) (tak 18 12 (if input 6 0))))))) diff --git a/collects/tests/racket/benchmarks/common/triangle-typed.rktl b/collects/tests/racket/benchmarks/common/triangle-typed.rktl index 0531e417bd..7b17cec1cc 100644 --- a/collects/tests/racket/benchmarks/common/triangle-typed.rktl +++ b/collects/tests/racket/benchmarks/common/triangle-typed.rktl @@ -89,7 +89,7 @@ ;;; call: (gogogo 22)) -(time (let: loop : 'done ((n : Integer 100000)) +(time (let: loop : 'done ((n : Integer 1000000)) (if (zero? n) 'done (begin diff --git a/collects/tests/racket/benchmarks/common/triangle.sch b/collects/tests/racket/benchmarks/common/triangle.sch index 700a00a9b0..e2038b60a4 100644 --- a/collects/tests/racket/benchmarks/common/triangle.sch +++ b/collects/tests/racket/benchmarks/common/triangle.sch @@ -78,7 +78,7 @@ ;;; call: (gogogo 22)) -(time (let loop ((n 100000)) +(time (let loop ((n 1000000)) (if (zero? n) 'done (begin From 5a432f3c9c47f2a1bcfa555931cfb3ad66f94e9b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 26 May 2010 17:05:18 -0400 Subject: [PATCH 27/52] Switch installation names to "Racket" --- collects/meta/build/build | 85 ++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 42 deletions(-) diff --git a/collects/meta/build/build b/collects/meta/build/build index 6b17c85781..ebec6d46de 100755 --- a/collects/meta/build/build +++ b/collects/meta/build/build @@ -41,7 +41,7 @@ buildnotifyemail="" init_repo_vars() { # use this function to initialize these on remote builds too gitbranch="${RKTBRANCH:-master}" - svnipath="${PLTSVNIPATH:-trunk}" + svnipath="${RKTSVNIPATH:-trunk}" } init_repo_vars @@ -55,7 +55,7 @@ dmgmachine="kauai" nsismachine="pitcairn" # list of environment variables that should be carried over to ssh jobs -ssh_vars=(RKTBRANCH PLTSVNIPATH) +ssh_vars=(RKTBRANCH RKTSVNIPATH) # Add stuff to be msetted later (when we have the `mset' function) declare -a initial_msets machines @@ -115,8 +115,8 @@ hostname="${hostname%%.*}" # web directory for pre-prelease stuff on $workmachine (relative to $maindir) prewebdir="html" # directory for installation (relative to $maindir) -installdir="plt" -# directory in plt for build-related scripts (includes this script) +installdir="racket" +# directory in racket for build-related scripts (includes this script) scriptdir="collects/meta/build" # directory for internal stuff (relative to $maindir) internaldir="iplt" @@ -148,7 +148,7 @@ htmlpatchscript="$scriptdir/patch-html" # sitemap materials sitemapdir="$scriptdir/sitemap" -# platform-installer stuff, all relative the the plt tree +# platform-installer stuff, all relative the the racket tree nsisdir="$scriptdir/nsis" unixinstallerdir="$scriptdir/unix-installer" unixpathcheckscript="$unixinstallerdir/check-install-paths" @@ -166,15 +166,15 @@ stampfile="stamp" # directory for temporary stuff (absolute path) -- on all machines tmpdir="/tmp" # lockfile for this script -lockfile="/tmp/plt-build-lock" +lockfile="/tmp/racket-build-lock" # name for running this script remotely -remotebuildscript="$tmpdir/build-plt" +remotebuildscript="$tmpdir/build-racket" # full name for clean repository tgz file to transfer for distributed builds repotgz="$tmpdir/$cleantgz" # full name for full tgz file (with binaries etc) fulltgz="$tmpdir/$installdir-full.tgz" # log file name prefix for background jobs -bglogfile="$tmpdir/plt-bg-log" +bglogfile="$tmpdir/racket-bg-log" last_part() { echo "$*" | sed 's/.*[ -]//' @@ -241,9 +241,9 @@ extra_description_of_platform() { } name_of_dist_package() { case "$1" in - ( "mz" ) echo "MzScheme" ;; - ( "plt" ) echo "PLT Scheme" ;; - ( "full" ) echo "PLT Scheme Full" ;; + ( "mz" ) echo "Racket Textual" ;; + ( "plt" ) echo "Racket" ;; + ( "full" ) echo "Racket Full" ;; ( * ) exit_error "Unknown package name for name_of_dist_package: \"$1\"" ;; esac } @@ -305,12 +305,12 @@ explanation_of_installer_type() { case "$1" in ( "tgz" ) echo "Unpack this file using" \ "\"gunzip | tar xvf -\"." ;; - ( "dmg" ) echo "Mount this disk image and copy the PLT folder to your" \ - "disk." ;; + ( "dmg" ) echo "Mount this disk image and copy the Racket folder to" \ + "your disk." ;; ( "idmg" ) echo "Some browsers will automatically mount & copy the" \ - "\"PLT Scheme\" folder to your desktop; if yours" \ - "does not, mount the disk and copy it yourself." ;; - ( "zip" ) echo "Use unzip to extract the PLT folder to your disk." ;; + "\"Racket\" folder to your desktop; if yours does not," \ + "mount the disk and copy it yourself." ;; + ( "zip" ) echo "Use unzip to extract the Racket folder to your disk." ;; ( "sh" ) echo "Execute this file with \"sh \"," \ "and follow the instructions." ;; ( "exe" ) echo "This is a standard Windows installer." ;; @@ -319,10 +319,10 @@ explanation_of_installer_type() { esac } -# This is for running mzscheme scripts, unrelated to the build itself +# This is for running racket scripts, unrelated to the build itself export PLTHOME="$maindir/$installdir" \ PLT_EXTENSION_LIB_PATHS="" \ - PLTPLANETDIR="/tmp/plt-build-planet" + PLTPLANETDIR="/tmp/racket-build-planet" export PATH="$PLTHOME/bin:$PATH" unset PLTCOLLECTS; export PLTCOLLECTS @@ -801,7 +801,7 @@ _timeout_run() { # first input is the timeout Xvncpid="" Xwmpid="" _start_xvnc() { - local xvnclog="$tmpdir/plt-xvnc-log" + local xvnclog="$tmpdir/racket-xvnc-log" show "Starting Xvnc (logfile at \"$xvnclog\")" # Create Xauth cookie cookie="`mcookie`" @@ -811,7 +811,7 @@ _start_xvnc() { Xvnc "$DISPLAY" \ -rfbport 6565 \ -localhost \ - -desktop "PLT-Session" \ + -desktop "Racket-Session" \ -geometry 1024x768 \ -depth 16 \ -httpPort=0 \ @@ -1046,7 +1046,7 @@ MAIN_BUILD() { show "Creating archive" git archive --format=tar "$gitbranch" | gzip > "$repotgz" \ || exit_error "Could not create archive" - git archive --format=tar --prefix=plt/ "$gitbranch" \ + git archive --format=tar --prefix=racket/ "$gitbranch" \ | gzip > "$maindir/$cleantgz" \ || exit_error "Could not create archive" _cd "$maindir" @@ -1238,7 +1238,7 @@ DO_BUILD() { # inputs -- releasing elif [[ "$(( $RANDOM % 2 ))" = "0" ]]; then test_mode="rnd"; fi; separator "${machine}(${platform}) testing Racket ($test_mode)" - local testdir="$tmpdir/mztests" + local testdir="$tmpdir/racket-tests" _rmcd "$testdir" local _exe _jit exe flags @@ -1300,7 +1300,7 @@ DO_BUILD() { # inputs -- releasing # copy the installation to a backup directory, leaving one # backup of the old backup tree if it was there (this is used on # the build machine, so there's an updated copy of the tree at - # ~scheme/plt); the main work directory is kept the same. + # ~scheme/racket); the main work directory is kept the same. if [[ -e "$installdir-backup" ]]; then _rm "$installdir-backup"; fi if [[ -e "$installdir" ]]; then _mv "$installdir" "$installdir-backup"; fi _mv "$installdir-new" "$installdir" @@ -1328,9 +1328,9 @@ build_w32step() { # inputs: type, name, [args...] ;; ( "NMAKE" ) _run "$NMAKE" "$@" ;; - ( "MZCGC" ) _run "$PLTHOME/RacketCGC.exe" "$@" + ( "RKTCGC" ) _run "$PLTHOME/RacketCGC.exe" "$@" ;; - ( "MZ" ) # prefer using no-suffix, then 3m, and then cgc + ( "RKT" ) # prefer using no-suffix, then 3m, and then cgc # (needed because cgc is used to build 3m) local E="$PLTHOME/Racket" if [[ -x "${E}.exe" ]]; then _run "${E}.exe" "$@" @@ -1387,21 +1387,22 @@ DO_WIN32_BUILD() { separator "win32: Full build" build_w32step VSNET "racket" build_w32step VSNET "gracket" - _cd "$PLTHOME/src/worksp/gc2"; build_w32step MZ "3M" make.ss + _cd "$PLTHOME/src/worksp/gc2"; build_w32step RKT "3M" make.ss _cd "$PLTHOME" build_w32step VSNET "mzstart" build_w32step VSNET "mrstart" separator "win32: Building libraries" - _cd "$PLTHOME"; build_w32step MZ "mzc" -l- setup -Dl compiler + _cd "$PLTHOME" + build_w32step RKT "compiler" -N raco -l- raco setup -Dl compiler build_w32step VSNET3M "mzcom" build_w32step VSNET3M "libmysterx" # _cd "$PLTHOME/src/srpersist" # build_w32step NMAKE "srpersist" /f srpersist.mak "install" - _cd "$PLTHOME"; build_w32step MZ "raco setup" $SETUP_ARGS + _cd "$PLTHOME"; build_w32step RKT "raco setup" $SETUP_ARGS separator "win32: Building Cygwin libreries" _mcd "$PLTHOME/src/build" @@ -1420,7 +1421,7 @@ DO_WIN32_BUILD() { # _cp "mzdynb.obj" "mzdynb.def" "$PLTHOME/lib/bcc" _cd "$PLTHOME" - build_w32step MZ "winvers" -l setup/winvers; sleep 240 + build_w32step RKT "winvers" -l setup/winvers; sleep 240 } @@ -1436,7 +1437,7 @@ BUILD_DOCS_AND_PDFS() { html_table_begin { html_file_row "html" \ - "html files for on-line browsing (same as plt/collecs/doc)" + "html files for on-line browsing (same as racket/collecs/doc)" _rm "html" _cp -r "$workdir/$installdir/doc" "html" } @@ -1539,7 +1540,7 @@ BUILD_BUNDLES() { # platform-specific installer makers: # $1 is input file, $2 is the output (without suffix) -# $3 is the package name (mz/plt), $4 is the type (bin/src) +# $3 is the package name (textual/racket), $4 is the type (bin/src) # $5 is the platform name (unix/mac/win for src distributions) #---------------------------------------- @@ -1729,9 +1730,9 @@ tgz_to_exe() { fi local dname case "$pname" in - ( "plt" ) dname="PLT" ;; - ( "mz" ) dname="MzScheme" ;; - ( "full" ) dname="PLT-FULL" ;; + ( "mz" ) dname="Racket-Textual" ;; + ( "plt" ) dname="Racket" ;; + ( "full" ) dname="Racket-Full" ;; ( * ) exit_error "Unknown package name for exe installer: \"$pname\"" ;; esac if [[ "$releasing" != "yes" ]]; then @@ -1786,7 +1787,7 @@ do_installers_page_body() { # input: selector-html table-html # another case that matches full-...-src and uses the clean tgz file="../$cleantgz" fsize="`get_first du -h \"$file\"`" - expl="This is a gzipped-tarball of the full PLT sources," + expl="This is a gzipped-tarball of the full Racket sources," expl="$expl for all platforms." echo " else if (/^full-.*-src-*/.test(d))" \ "{ t = '$file'; c = '$file ($fsize)\n$expl' }" @@ -1913,20 +1914,20 @@ BUILD_INSTALLERS() { _cd "$maindir/$instdir" show "Making the distributions page" - _rm "$tmpdir/plt-tmp-selector" "$tmpdir/plt-tmp-table" - do_installers_page_body "$tmpdir/plt-tmp-selector" "$tmpdir/plt-tmp-table" + _rm "$tmpdir/rkt-tmp-selector" "$tmpdir/rkt-tmp-table" + do_installers_page_body "$tmpdir/rkt-tmp-selector" "$tmpdir/rkt-tmp-table" # selector page html_begin "Installers" html_content_begin - html_show -f "$tmpdir/plt-tmp-selector" + html_show -f "$tmpdir/rkt-tmp-selector" html_content_end html_end # static table page html_begin "Installers (static)" "table.html" html_content_begin html_table_begin "all" - html_show -f "$tmpdir/plt-tmp-table" - _rm "$tmpdir/plt-tmp-selector" "$tmpdir/plt-tmp-table" + html_show -f "$tmpdir/rkt-tmp-table" + _rm "$tmpdir/rkt-tmp-selector" "$tmpdir/rkt-tmp-table" html_table_end html_content_end html_end @@ -1986,7 +1987,7 @@ BUILD_WEB() { _mcd "$maindir/$w" - html_begin "PLT Nightly Builds" + html_begin "Racket Nightly Builds" html_content_begin html_table_begin #---- @@ -2054,7 +2055,7 @@ BUILD_WEB() { separator "Creating a site-map" _cd "$maindir/$w" _run "$PLTHOME/$sitemapdir/sitemap_gen.py" \ - --config="$PLTHOME/$sitemapdir/plt-pre.xml" \ + --config="$PLTHOME/$sitemapdir/rkt-pre.xml" \ > /dev/null fi From bc242e06f320007549d9070ebaf33fb1446e0b60 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 26 May 2010 21:29:18 -0400 Subject: [PATCH 28/52] Some "plt" -> "racket" in distribution files and other meta stuff. --- collects/meta/build/bundle | 53 +++++++++++++++-------------- collects/meta/check-dists.rkt | 17 ++++++---- collects/meta/checker.rkt | 33 +++++++++--------- collects/meta/dist-specs.rkt | 64 +++++++++++++++++------------------ collects/meta/props | 14 ++++---- collects/meta/readme.txt | 2 +- collects/meta/spec-lang.rkt | 2 +- 7 files changed, 95 insertions(+), 90 deletions(-) diff --git a/collects/meta/build/bundle b/collects/meta/build/bundle index e9027fd33c..48c27820c6 100755 --- a/collects/meta/build/bundle +++ b/collects/meta/build/bundle @@ -13,18 +13,18 @@ (define home/ (/-ify (expand-user-path "~scheme"))) (define binaries/ (/-ify (build-path home/ "binaries"))) (define target/ (/-ify (build-path home/ "pre-installers"))) -(define plt/ (/-ify (or (getenv "PLTHOME") +(define racket/ (/-ify (or (getenv "PLTHOME") (error 'bundle "PLTHOME is not defined")))) -(define plt-base/ (/-ify (simplify-path (build-path plt/ 'up) #f))) -(define plt/-name (let-values ([(base name dir?) (split-path plt/)]) - (path-element->string name))) +(define racket-base/ (/-ify (simplify-path (build-path racket/ 'up) #f))) +(define racket/-name (let-values ([(base name dir?) (split-path racket/)]) + (path-element->string name))) (define cd current-directory) (define *readme-file* - (build-path plt/ "README")) + (build-path racket/ "README")) (define *info-domain-file* - (build-path plt/ "collects" "info-domain" "compiled" "cache.rktd")) + (build-path racket/ "collects" "info-domain" "compiled" "cache.rktd")) (define *readme-cache* #f) (define *info-domain-cache* #f) @@ -177,7 +177,7 @@ (set! /dev/null-in (open-input-file "/dev/null")) (unless (directory-exists? target/) (make-directory target/)) (let ([d (ormap (lambda (x) (and (not (directory-exists? x)) x)) - (list home/ plt/ binaries/ target/))]) + (list home/ racket/ binaries/ target/))]) (when d (error 'bundle "directory not found: ~a" d))) (set! *platforms* (parameterize ([cd binaries/]) @@ -203,10 +203,10 @@ (map (lambda (platform) (dprintf ".") (parameterize ([cd platform]) - ;; if no btgz *and* "plt" already created then use get-tree - ;; (useful when debugging stuff so re-use pre made ones) - ;; should work the same with an old tree - (if (and (directory-exists? "plt") (not *btgz?*)) + ;; if no btgz *and* "racket" already created then use + ;; get-tree (useful when debugging stuff so re-use pre made + ;; ones) should work the same with an old tree + (if (and (directory-exists? "racket") (not *btgz?*)) (filtered-map (lambda (x) ; only directories contain stuff we need (and (directory-exists? x) (get-tree x))) @@ -225,8 +225,8 @@ (when (null? trees) (error 'binaries "no binaries found for ~s" platform))) *platforms* *platform-tree-lists*) - ;; Get the plt tree, remove junk and binary stuff - (set-plt-tree! plt-base/ plt/-name *platform-tree-lists*) + ;; Get the racket tree, remove junk and binary stuff + (set-racket-tree! racket-base/ racket/-name *platform-tree-lists*) (set-bin-files-delayed-lists! (delay (map (lambda (trees) (sort* (mappend tree-flatten (add-trees trees)))) @@ -235,11 +235,11 @@ (define (make-info-domain trees) (unless (= 1 (length trees)) (error 'make-info-domain "got zero or multiple trees: ~e" trees)) - (let* ([collects (or (tree-filter "/plt/collects/" (car trees)) + (let* ([collects (or (tree-filter "/racket/collects/" (car trees)) (error 'make-info-domain "got no collects in tree"))] [info (filter (lambda (x) (let ([x (path->string (bytes->path (car x)))]) - (pair? (tree-filter (concat "/plt/collects/" x) + (pair? (tree-filter (concat "/racket/collects/" x) collects)))) *info-domain-cache*)]) (lambda () (write info) (newline)))) @@ -267,13 +267,14 @@ (define (create-binaries platform trees) (parameterize ([cd (build-path binaries/ platform)]) - (let ([full-tgz (concat "plt-"platform"-full.tgz")] - [bin-tgz (concat "plt-"platform"-binaries.tgz")] + (let ([full-tgz (concat "racket-"platform"-full.tgz")] + [bin-tgz (concat "racket-"platform"-binaries.tgz")] [all-tgzs (filter input-tgz-name? (map path->string (directory-list)))]) - (unless (and (directory-exists? "plt") (not *btgz?*)) + (unless (and (directory-exists? "racket") (not *btgz?*)) (dprintf "Unpacking binaries in ~s ~a\n" platform all-tgzs) - ;; even if a "plt" directory exists, we just overwrite the same stuff + ;; even if a "racket" directory exists, we just overwrite the same + ;; stuff (unless (member full-tgz all-tgzs) (error 'create-binaries "~a/~a not found" (cd) full-tgz)) (for ([tgz all-tgzs]) (unpack tgz trees))) @@ -285,9 +286,9 @@ (current-output-port) /dev/null-in (current-error-port) ;; see below for flag explanations /pax "-w" "-x" "ustar" "-z" "-f" bin-tgz - ;; only pack the plt dir (only exception is Libraries on - ;; OSX, but that has its own dir) - "plt")]) + ;; only pack the racket dir (only exception is Libraries + ;; on OSX, but that has its own dir) + "racket")]) (subprocess-wait p)))))) (define (pack archive trees prefix) @@ -472,7 +473,7 @@ (let ([name (format "~a-~a.tgz" name type)]) (dprintf "Creating ~s: filtering..." name) (let ([trees (add-trees - (cons (distribute (get-plt-tree)) + (cons (distribute (get-racket-tree)) (if bin? (tag 'in-binary-tree (map (if full? @@ -489,8 +490,8 @@ (chown 'root *readme-file* *info-domain-file*) (pack (concat target/ name) trees (if bin? - (format "\\(~a\\|~a~a/\\)" plt-base/ binaries/ type) - plt-base/))) + (format "\\(~a\\|~a~a/\\)" racket-base/ binaries/ type) + racket-base/))) (dprintf " done.\n"))))) '()) (register-spec! 'distribute! @@ -529,7 +530,7 @@ (define (chown-dirs-to who) (when (and *root?* *pack?*) (dprintf "Changing owner to ~a..." who) - (for ([dir (list plt/ binaries/)]) + (for ([dir (list racket/ binaries/)]) (parameterize ([cd dir]) (chown #:rec #t who "."))) (dprintf " done.\n"))) diff --git a/collects/meta/check-dists.rkt b/collects/meta/check-dists.rkt index 73cda3d5ca..700e839cf9 100644 --- a/collects/meta/check-dists.rkt +++ b/collects/meta/check-dists.rkt @@ -7,10 +7,13 @@ [current-namespace (namespace-anchor->namespace checker-namespace-anchor)]) (define (/-ify x) (regexp-replace #rx"/?$" (if (path? x) (path->string x) x) "/")) - (define plt/ (/-ify (simplify-path (build-path (collection-path "scheme") 'up 'up)))) - (define plt-base/ (/-ify (simplify-path (build-path plt/ 'up) #f))) - (define plt/-name (let-values ([(base name dir?) (split-path plt/)]) - (path-element->string name))) + (define racket/ + (/-ify (simplify-path (build-path (collection-path "scheme") 'up 'up)))) + (define racket-base/ + (/-ify (simplify-path (build-path racket/ 'up) #f))) + (define racket/-name + (let-values ([(base name dir?) (split-path racket/)]) + (path-element->string name))) (register-macros!) @@ -19,11 +22,11 @@ (register-spec! 'verify! verify!) (register-spec! 'distribute! void) - (set-plt-tree! plt-base/ plt/-name null) + (set-racket-tree! racket-base/ racket/-name null) - (set-bin-files-delayed-lists! + (set-bin-files-delayed-lists! ;; FIXME: hard-wired list of binary-specific files - '(("plt/collects/sgl/compiled/gl-info_ss.zo"))) + '(("racket/collects/sgl/compiled/gl-info_ss.zo"))) (expand-spec 'distributions) diff --git a/collects/meta/checker.rkt b/collects/meta/checker.rkt index 9f8c606566..fd6ab3c647 100644 --- a/collects/meta/checker.rkt +++ b/collects/meta/checker.rkt @@ -449,23 +449,23 @@ file v version)))))) (define (add-dependency-contents!) - (define (pltpath path) + (define (racketpath path) (bytes->string/utf-8 (apply bytes-append (cdr (mappend (lambda (p) (list #"/" p)) - (list* #"plt" #"collects" path)))))) + (list* #"racket" #"collects" path)))))) (define (read-depfile file) (let ([x (with-input-from-file file read)]) (unless (and (pair? x) (check-version (car x) file)) (error 'dependencies "bad contents in ~s: ~s" file x)) (map (lambda (x) (match x - [`(collects ,(and (? bytes?) s) ...) (pltpath s)] - [`(ext collects ,(and (? bytes?) s) ...) (pltpath s)] + [`(collects ,(and (? bytes?) s) ...) (racketpath s)] + [`(ext collects ,(and (? bytes?) s) ...) (racketpath s)] [_ (error 'dependencies "bad dependency item in ~s: ~s" file x)])) (cddr x)))) (dprintf "Reading dependencies...") - (let loop ([tree (tree-filter "*.dep" *plt-tree*)]) + (let loop ([tree (tree-filter "*.dep" *racket-tree*)]) (if (pair? tree) (for-each loop (cdr tree)) (parameterize ([cd (prop-get tree 'base)]) @@ -490,12 +490,13 @@ (define (check-dependencies spec distname) (add-dependency-contents!) (dprintf "Verifying dependencies for ~s..." distname) - (let* ([all-files (sort* (add-alts (tree-flatten (tree-filter spec *plt-tree*))))] - [deps0 (or (tree-filter `(and ,spec "*.dep") *plt-tree*) + (let* ([all-files + (sort* (add-alts (tree-flatten (tree-filter spec *racket-tree*))))] + [deps0 (or (tree-filter `(and ,spec "*.dep") *racket-tree*) (error 'check-dependencies "got no .dep files for ~s" distname))] [deps0 (tree-flatten deps0 #t)]) - (let* ([missing (tree-filter 'must-be-empty *plt-tree*)] + (let* ([missing (tree-filter 'must-be-empty *racket-tree*)] [missing (and (pair? missing) (tree-flatten missing #t))]) (when (pair? missing) (dprintf "files missing from distribution:\n") @@ -538,11 +539,10 @@ ;;; Start working (define *platform-tree-lists* null) -(define *plt-tree* #f) +(define *racket-tree* #f) -(provide get-plt-tree) -(define (get-plt-tree) - *plt-tree*) +(provide get-racket-tree) +(define (get-racket-tree) *racket-tree*) (provide verify!) (define (verify!) @@ -556,12 +556,13 @@ (provide checker-namespace-anchor) (define-namespace-anchor checker-namespace-anchor) -(provide set-plt-tree!) -(define (set-plt-tree! plt-base/ plt/-name tree-lists) +(provide set-racket-tree!) +(define (set-racket-tree! racket-base/ racket/-name tree-lists) (set! *platform-tree-lists* tree-lists) (dprintf "Scanning main tree...") - (set! *plt-tree* - (let loop ([tree (parameterize ([cd plt-base/]) (get-tree plt/-name))] + (set! *racket-tree* + (let loop ([tree (parameterize ([cd racket-base/]) + (get-tree racket/-name))] [trees (apply append *platform-tree-lists*)]) (if (null? trees) (tree-filter '(not junk) tree) diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index 8161f7dd4d..3c4666af77 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -3,7 +3,7 @@ ;; -*- scheme -*- ;; ============================================================================ -;; This file holds the specifications for creating PLT distributions. These +;; This file holds the specifications for creating Racket distributions. These ;; specifications are defined by a sequence of := ... definitions ;; (note: no parens), which binds the symbol to a tree specification. In ;; addition, a definition can use `:=tag' which will go into a special space of @@ -75,7 +75,7 @@ distributions := (tag "mz" bin+src+dist) (tag "mr" bin+src-dist) (tag "dr" bin+src-dist) - (tag "plt" bin+src+dist) + (tag "racket" bin+src+dist) (tag ("full" "bin") (distribute!)) bin+src+dist := (tag "bin" (verify!) (distribute!)) (tag "src" (verify!) (distribute!)) @@ -141,11 +141,11 @@ distribution-filters := ;; (note: this rule means that we could avoid specifying docs and just include ;; the whole thing -- but this way we make sure that all doc sources are ;; included too (since they're specified together).) -must-be-empty := (cond docs => (- "/plt/doc/" distribution) else => none) +must-be-empty := (cond docs => (- "/racket/doc/" distribution) else => none) compiled-filter := (- (collects: "**/compiled/") (cond verifying => "*.dep")) - "/plt/bin/" "/plt/lib/" + "/racket/bin/" "/racket/lib/" src-filter := (src: "") docs-filter := (- (doc: "") ; all docs, (notes: "") ; excluding basic stuff @@ -173,7 +173,7 @@ std-docs := (doc: "doc-license.txt" "*-std/") ;; (the first line shouldn't be necessary, but be safe) junk := (+ ".git*" "/.mailmap" ".svn" "CVS/" "[.#]*" "*~" ;; binary stuff should come from the platform directories - "/plt/bin/" "/plt/lib/" "/plt/src/*build*/") + "/racket/bin/" "/racket/lib/" "/racket/src/*build*/") ;; These are handled in a special way by the bundle script: the binary trees ;; are scanned for paths that have "{3m|cgc}" where a "" @@ -201,13 +201,13 @@ junk := (+ ".git*" "/.mailmap" ".svn" "CVS/" "[.#]*" "*~" ;; covered by these templates. binary-keep/throw-templates := - "/plt/{lib|include}/**/*.*" - "/plt/bin/*" - (cond win => "/plt/*.exe" - "/plt/lib/**/lib*???????.{dll|lib|exp}" - mac => "/plt/*.app/" - "/plt/lib/*Racket*.framework/Versions/*<_!>/") - "/plt/collects/**/compiled/**/*.*" + "/racket/{lib|include}/**/*.*" + "/racket/bin/*" + (cond win => "/racket/*.exe" + "/racket/lib/**/lib*???????.{dll|lib|exp}" + mac => "/racket/*.app/" + "/racket/lib/*Racket*.framework/Versions/*<_!>/") + "/racket/collects/**/compiled/**/*.*" binary-keep := "3[mM]" binary-throw := "{cgc|CGC}" @@ -216,7 +216,7 @@ binary-throw := "{cgc|CGC}" ;; don't follow the above (have no 3m or cgc in the name, and no keep version ;; of the same name that will make them disappear) binary-throw-more := - "/plt/lib/**/libmzgc???????.{dll|lib}" + "/racket/lib/**/libmzgc???????.{dll|lib}" ;; ============================================================================ ;; Convenient macros @@ -229,7 +229,7 @@ plt-path: := (lambda (prefix . paths) (when (and (pair? paths) (eq? ': (car paths))) (set! suffix (cadr paths)) (set! paths (cddr paths))) `(+ ,@(map (lambda (path) - (concat "/plt/" prefix + (concat "/racket/" prefix (regexp-replace #rx"^/" path "") suffix)) paths)))) @@ -282,12 +282,12 @@ srcfile: := dll: := (lambda fs `(+ ,@(map (lambda (f) - (concat "/plt/lib/" (regexp-replace - #rx"^/" (expand-spec-1 f) "") + (concat "/racket/lib/" + (regexp-replace #rx"^/" (expand-spec-1 f) "") "{|3[mM]|cgc|CGC}{|???????}.dll")) fs) ,@(map (lambda (f) - (concat "/plt/lib/**/" + (concat "/racket/lib/**/" (regexp-replace #rx"^.*/" (expand-spec-1 f) "") "{|3[mM]|cgc|CGC}{|???????}.lib")) fs))) @@ -327,9 +327,9 @@ plt := (+ dr plt-extras) ;; ============================================================================ ;; Packages etc -mz-base := "/plt/README" +mz-base := "/racket/README" (package: "racket") (package: "mzscheme") - "/plt/include/" + "/racket/include/" ;; configuration stuff (cond (not src) => (collects: "info-domain/")) ; filtered (package: "config") @@ -411,19 +411,19 @@ extra-dynlibs := (cond win => (dll: "{ssl|lib}eay32")) ;; This filter is used on the full compiled trees to get the binary ;; (platform-dependent) portion out. -binaries := (+ "/plt/bin/" - "/plt/lib/" - "/plt/include/" - "/plt/collects/**/compiled/native/" - (cond unix => "/plt/bin/{|g}racket*" - "/plt/bin/{mzscheme|mred}*" - win => "/plt/*.exe" - "/plt/*.dll" - "/plt/collects/launcher/*.exe" - mac => "/plt/bin/racket*" - "/plt/bin/mzscheme*" - "/plt/*.app" - "/plt/collects/launcher/*.app") +binaries := (+ "/racket/bin/" + "/racket/lib/" + "/racket/include/" + "/racket/collects/**/compiled/native/" + (cond unix => "/racket/bin/{|g}racket*" + "/racket/bin/{mzscheme|mred}*" + win => "/racket/*.exe" + "/racket/*.dll" + "/racket/collects/launcher/*.exe" + mac => "/racket/bin/racket*" + "/racket/bin/mzscheme*" + "/racket/*.app" + "/racket/collects/launcher/*.app") platform-dependent) platform-dependent := ; hook for package rules diff --git a/collects/meta/props b/collects/meta/props index 0ed56ea32e..b2d4b931f5 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -6,7 +6,7 @@ exec racket -um "$0" "$@" #| -This file contains "properties" of various files and directories in the PLT +This file contains "properties" of various files and directories in the Racket tree. Its format is briefly described below, but it is mainly intended to be used as a command-line script -- run it with `-h' to find out how to use it. In addition, you can make it work as a git command -- put this in a file @@ -31,7 +31,7 @@ sequence of path and properties for it: ... -where is a "/"-delimited string (relative to the plt tree root), +where is a "/"-delimited string (relative to the racket root), is one of a few known property symbols, and is the assigned value. The value is should follow the predicate specification for the property, which is defined as `known-props' before the properties data block; note that it is @@ -46,7 +46,7 @@ are set by running this file as a script). Requiring this file builds the data table and provides an interface for properties, intended to be used by meta tools. In these functions, `path' is a path argument that is given as a "/"-delimited and normalized path -string (no ".", "..", "//", or a "/" suffix) relative to the plt tree root, and +string (no ".", "..", "//", or a "/" suffix) relative to the racket root, and path/s is either such a string or a list of them. * (get-prop path/s prop [default] @@ -349,14 +349,14 @@ path/s is either such a string or a list of them. "This is a utility for manipulating properties in the PLT repository." "Each of the following subcommands expects a property name from a set of" "known properties. The given paths are normalized to be relative to the" - "plt root for the tree holding this script *if* it is in such a tree" + "racket root for the tree holding this script *if* it is in such a tree" "(determined by inspecting a few known directories), otherwise an error" "is raised." "" "Note: this script holds the data that it changes, so you need to commit" "it after changes are made." "" - "Note: it does not depend on the plt installation that runs it -- you" + "Note: it does not depend on the racket installation that runs it -- you" "just need to use the script from the work directory that you want to" "deal with; if you add a git alias like:" " prop = \"!$(git rev-parse --show-toplevel)/collects/meta/props\"" @@ -388,7 +388,7 @@ path/s is either such a string or a list of them. p) (if (> n 0) (loop base (sub1 n)) - (error* #f "could not find the plt root from ~a" + (error* #f "could not find the racket root from ~a" (path-only this-file)))))))) (define check-existing-paths? #t) (define (paths->list path paths) @@ -405,7 +405,7 @@ path/s is either such a string or a list of them. "" (let ([n (path->string n)]) (if (regexp-match #rx"^\\.\\.(?:/|$)" n) - (error* #f "path is not in the plt tree: ~s" p) + (error* #f "path is not in the racket tree: ~s" p) n))))) (if (null? paths) (norm path) (map norm (cons path paths)))))) (define (get prop path . paths) diff --git a/collects/meta/readme.txt b/collects/meta/readme.txt index 921f8ac817..b8fda38770 100644 --- a/collects/meta/readme.txt +++ b/collects/meta/readme.txt @@ -1 +1 @@ -This directory contains code that is used to manage PLT infrastructure. +This directory contains code that is used to manage Racket infrastructure. diff --git a/collects/meta/spec-lang.rkt b/collects/meta/spec-lang.rkt index 6d10b54d0f..1fe7b6a2bd 100644 --- a/collects/meta/spec-lang.rkt +++ b/collects/meta/spec-lang.rkt @@ -4,7 +4,7 @@ (provide (rename-out [module-begin #%module-begin])) (define-syntax-rule (module-begin . rest) - (#%module-begin + (#%module-begin (provide register-specs!) (define (register-specs! [param *specs*]) (process-specs 'rest param)))) From c96bbe640d2e3254c255cfedf1e467b111cb83a5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 26 May 2010 16:54:00 -0500 Subject: [PATCH 29/52] =?UTF-8?q?makes=20image=3D=3F=20work=20on=202htdp/i?= =?UTF-8?q?mage=20images.?= --- collects/lang/private/imageeq.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/lang/private/imageeq.rkt b/collects/lang/private/imageeq.rkt index a3e7397f77..c1eb2ad084 100644 --- a/collects/lang/private/imageeq.rkt +++ b/collects/lang/private/imageeq.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/gui/base mrlib/cache-image-snip + (prefix-in 2htdp/image: mrlib/image-core) mzlib/class) (provide scene? image? image=? @@ -13,8 +14,8 @@ (is-a? a cache-image-snip%))) (define (image=? a-raw b-raw) - (unless (image? a-raw) (raise-type-error 'image=? "image" 0 a-raw b-raw)) - (unless (image? b-raw) (raise-type-error 'image=? "image" 1 a-raw b-raw)) + (unless (or (2htdp/image:image? a-raw) (image? a-raw)) (raise-type-error 'image=? "image" 0 a-raw b-raw)) + (unless (or (2htdp/image:image? b-raw) (image? b-raw)) (raise-type-error 'image=? "image" 1 a-raw b-raw)) ;; Rely on image-snip% implementing equal<%>: (equal? a-raw b-raw)) From b5364a58751cafb49faa92def264cdcfb26c1f99 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 26 May 2010 17:03:44 -0500 Subject: [PATCH 30/52] fixed a bug in the docs typo Not for the release (because it modifies a file that has been changed too much and because this commit is a minor change) --- collects/teachpack/2htdp/scribblings/image.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 8450883eb8..57584c287f 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -868,7 +868,7 @@ the parts that fit onto @racket[scene]. (image-height (rectangle 10 0 "solid" "purple"))] } -@defproc[(image-baseline [i image?]) (and/c integer? positive? exact?)]{ +@defproc[(image-baseline [i image?]) (and/c integer? (not/c negative?) exact?)]{ Returns the distance from the top of the image to its baseline. Unless the image was constructed with @racket[text] or @racket[text/font], this will be the same as its height. From 4cdfbb28d7042e1426e1df908b0471a8dcdd11df Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 27 May 2010 02:33:16 -0400 Subject: [PATCH 31/52] A few minor fixes --- collects/meta/build/build | 2 +- collects/meta/build/nsis/installer.nsi | 2 +- collects/meta/dist-specs.rkt | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/meta/build/build b/collects/meta/build/build index ebec6d46de..8a887acd3a 100755 --- a/collects/meta/build/build +++ b/collects/meta/build/build @@ -2055,7 +2055,7 @@ BUILD_WEB() { separator "Creating a site-map" _cd "$maindir/$w" _run "$PLTHOME/$sitemapdir/sitemap_gen.py" \ - --config="$PLTHOME/$sitemapdir/rkt-pre.xml" \ + --config="$PLTHOME/$sitemapdir/plt-pre.xml" \ > /dev/null fi diff --git a/collects/meta/build/nsis/installer.nsi b/collects/meta/build/nsis/installer.nsi index f61d3fd334..4759e8f398 100644 --- a/collects/meta/build/nsis/installer.nsi +++ b/collects/meta/build/nsis/installer.nsi @@ -177,7 +177,7 @@ Section "" DetailPrint "Installing Racket..." SetDetailsPrint listonly SetOutPath "$INSTDIR" - File /a /r "plt\*.*" + File /a /r "racket\*.*" !ifndef SimpleInstaller WriteUninstaller "${UNINSTEXE}" ; Create uninstaller !endif diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index 3c4666af77..af4d36c5c8 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -75,7 +75,7 @@ distributions := (tag "mz" bin+src+dist) (tag "mr" bin+src-dist) (tag "dr" bin+src-dist) - (tag "racket" bin+src+dist) + (tag "plt" bin+src+dist) (tag ("full" "bin") (distribute!)) bin+src+dist := (tag "bin" (verify!) (distribute!)) (tag "src" (verify!) (distribute!)) From 44a7a71923fdadb786026de0c3d952fa4e398ca2 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 21 May 2010 16:03:49 -0400 Subject: [PATCH 32/52] Corrected the typed versions of some benchmarks to be closer to the untyped versions. --- .../racket/benchmarks/common/ctak-typed.rktl | 48 +++++++++---------- .../racket/benchmarks/common/div-typed.rktl | 14 +++--- .../racket/benchmarks/common/fft-typed.rktl | 18 +++---- .../tests/racket/benchmarks/common/fft.sch | 2 +- .../benchmarks/common/graphs-typed.rktl | 12 ++--- .../benchmarks/common/mazefun-typed.rktl | 18 +++---- .../benchmarks/common/paraffins-typed.rktl | 2 - .../benchmarks/common/puzzle-typed.rktl | 18 +++---- 8 files changed, 65 insertions(+), 67 deletions(-) diff --git a/collects/tests/racket/benchmarks/common/ctak-typed.rktl b/collects/tests/racket/benchmarks/common/ctak-typed.rktl index d04e765808..f7ee52812e 100644 --- a/collects/tests/racket/benchmarks/common/ctak-typed.rktl +++ b/collects/tests/racket/benchmarks/common/ctak-typed.rktl @@ -23,36 +23,36 @@ (: ctak (Integer Integer Integer -> Integer)) (define (ctak x y z) - ((inst call-with-current-continuation Integer Integer) - (lambda (k) + (call-with-current-continuation + (lambda: ((k : (Integer -> Nothing))) (ctak-aux k x y z)))) (: ctak-aux ((Integer -> Integer) Integer Integer Integer -> Integer)) (define (ctak-aux k x y z) (cond ((not (< y x)) ;xy (k z)) - (else ((inst call-with-current-continuation Integer Integer) - (lambda (dummy) - (ctak-aux - k - ((inst call-with-current-continuation Integer Integer) - (lambda (k) - (ctak-aux k - (- x 1) - y - z))) - ((inst call-with-current-continuation Integer Integer) - (lambda (k) - (ctak-aux k - (- y 1) - z - x))) - ((inst call-with-current-continuation Integer Integer) - (lambda (k) - (ctak-aux k - (- z 1) - x - y))))))))) + (else (call-with-current-continuation + (let ([v (ctak-aux + k + (call-with-current-continuation + (lambda: ((k : (Integer -> Nothing))) + (ctak-aux k + (- x 1) + y + z))) + (call-with-current-continuation + (lambda: ((k : (Integer -> Nothing))) + (ctak-aux k + (- y 1) + z + x))) + (call-with-current-continuation + (lambda: ((k : (Integer -> Nothing))) + (ctak-aux k + (- z 1) + x + y))))]) + (lambda (dummy) v)))))) ;;; call: (ctak 18 12 6) diff --git a/collects/tests/racket/benchmarks/common/div-typed.rktl b/collects/tests/racket/benchmarks/common/div-typed.rktl index 4317858b2d..47ceac80d6 100644 --- a/collects/tests/racket/benchmarks/common/div-typed.rktl +++ b/collects/tests/racket/benchmarks/common/div-typed.rktl @@ -33,21 +33,21 @@ (cond ((null? l) '()) (else (cons (car l) (recursive-div2 (cddr l)))))) -(: test-1 ((Listof Any) -> (Listof Any))) +(: test-1 ((Listof Any) -> Void)) (define (test-1 l) - (do: : (Listof Any) + (do: : Void ((i : Integer 3000 (- i 1))) - ((= i 0) '()) + ((= i 0)) (iterative-div2 l) (iterative-div2 l) (iterative-div2 l) (iterative-div2 l))) -(: test-2 ((Listof Any) -> (Listof Any))) +(: test-2 ((Listof Any) -> Void)) (define (test-2 l) - (do: : (Listof Any) + (do: : Void ((i : Integer 3000 (- i 1))) - ((= i 0) '()) + ((= i 0)) (recursive-div2 l) (recursive-div2 l) (recursive-div2 l) @@ -58,7 +58,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time (let: loop : (Pair Void Void) - ((n : Integer 200) (v : (U Integer (Listof Any)) 0)) + ((n : Integer 200) (v : (Pair Void Void) (cons (void) (void)))) (if (zero? n) v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/fft-typed.rktl b/collects/tests/racket/benchmarks/common/fft-typed.rktl index 4477ece38b..be083fcb22 100644 --- a/collects/tests/racket/benchmarks/common/fft-typed.rktl +++ b/collects/tests/racket/benchmarks/common/fft-typed.rktl @@ -81,9 +81,9 @@ (set! i (+ i 1)) (cond ((< i n) (l3)))) - (do: : Null + (do: : Void ((l : Integer 1 (+ l 1))) ;loop thru stages (syntax converted - ((> l m) '()) ; from old MACLISP style \bs) + ((> l m)) ; from old MACLISP style \bs) (set! le (expt 2 l)) (set! le1 (quotient le 2)) (set! ur 1.0) @@ -91,13 +91,13 @@ (set! wr (cos (/ pi le1))) (set! wi (sin (/ pi le1))) ;; loop thru butterflies - (do: : Null + (do: : Void ((j : Integer 1 (+ j 1))) - ((> j le1) '()) + ((> j le1)) ;; do a butterfly - (do: : Null + (do: : Void ((i : Integer j (+ i le))) - ((> i n) '()) + ((> i n)) (set! ip (+ i le1)) (set! tr (- (* (vector-ref ar ip) ur) (* (vector-ref ai ip) ui))) @@ -115,11 +115,11 @@ ;;; the timer which does 10 calls on fft -(: fft-bench ( -> Null)) +(: fft-bench ( -> Void)) (define (fft-bench) - (do: : Null + (do: : Void ((ntimes : Integer 0 (+ ntimes 1))) - ((= ntimes 5000) '()) + ((= ntimes 5000)) (fft *re* *im*))) ;;; call: (fft-bench) diff --git a/collects/tests/racket/benchmarks/common/fft.sch b/collects/tests/racket/benchmarks/common/fft.sch index ae63c90291..2ed230819f 100644 --- a/collects/tests/racket/benchmarks/common/fft.sch +++ b/collects/tests/racket/benchmarks/common/fft.sch @@ -71,7 +71,7 @@ (let l6 () (cond ((< k j) (set! j (- j k)) - (set! k (/ k 2)) + (set! k (quotient k 2)) (l6)))) (set! j (+ j k)) (set! i (+ i 1)) diff --git a/collects/tests/racket/benchmarks/common/graphs-typed.rktl b/collects/tests/racket/benchmarks/common/graphs-typed.rktl index 9d566562e6..3840944890 100644 --- a/collects/tests/racket/benchmarks/common/graphs-typed.rktl +++ b/collects/tests/racket/benchmarks/common/graphs-typed.rktl @@ -141,7 +141,7 @@ state)))) ; Iterate over the integers [0, limit). -(: gnatural-for-each (Integer (Integer -> Any) -> Null)) +(: gnatural-for-each (Integer (Integer -> Any) -> Void)) (define gnatural-for-each (lambda (limit proc!) '(assert (and (integer? limit) @@ -150,10 +150,10 @@ limit) '(assert (procedure? proc!) proc!) - (do: : Null + (do: : Void ((i : Integer 0 (+ i 1))) - ((= i limit) '()) + ((= i limit)) (proc! i)))) (: natural-for-all? (Integer (Integer -> Boolean) -> Boolean)) @@ -686,10 +686,8 @@ (lambda: ((t : Integer)) (if (vector-ref from-m t) (begin ; [wdc - was when] - (vector-set! from-f t #t) - #t) - #t))) - #t) + (vector-set! from-f t #t)) + #t)))) #t))))))) res))) diff --git a/collects/tests/racket/benchmarks/common/mazefun-typed.rktl b/collects/tests/racket/benchmarks/common/mazefun-typed.rktl index 7c5c91b555..bf0ddcaec8 100644 --- a/collects/tests/racket/benchmarks/common/mazefun-typed.rktl +++ b/collects/tests/racket/benchmarks/common/mazefun-typed.rktl @@ -150,7 +150,7 @@ (make-matrix n m (lambda: ((i : Integer) (j : Integer)) (if (and (even? i) (even? j)) (cons i j) - '(0 . 0))))) + #f)))) (possible-holes (concat (for 0 n (lambda: ((i : Integer)) @@ -166,13 +166,14 @@ (lambda (cave) (matrix-map (lambda (x) (if x '_ '*)) cave))) -(: pierce (Pos (Matrix Pos) -> (Matrix Pos))) +(: pierce (Pos (Matrix (Option Pos)) -> (Matrix (Option Pos)))) (define pierce (lambda (pos cave) (let: ((i : Integer (car pos)) (j : Integer (cdr pos))) (matrix-write cave i j pos)))) -(: pierce-randomly ((Listof Pos) (Matrix Pos) -> (Matrix Pos))) +(: pierce-randomly ((Listof Pos) (Matrix (Option Pos)) + -> (Matrix (Option Pos)))) (define pierce-randomly (lambda (possible-holes cave) (if (null? possible-holes) @@ -181,7 +182,7 @@ (pierce-randomly (cdr possible-holes) (try-to-pierce hole cave)))))) -(: try-to-pierce (Pos (Matrix Pos) -> (Matrix Pos))) +(: try-to-pierce (Pos (Matrix (Option Pos)) -> (Matrix (Option Pos)))) (define try-to-pierce (lambda (pos cave) (let ((i (car pos)) (j (cdr pos))) @@ -192,24 +193,25 @@ ncs)) cave (pierce pos - (foldl (lambda: ((c : (Matrix Pos)) (nc : Pos)) + (foldl (lambda: ((c : (Matrix (Option Pos))) (nc : Pos)) (change-cavity c nc pos)) cave ncs))))))) -(: change-cavity ((Matrix Pos) Pos Pos -> (Matrix Pos))) +(: change-cavity ((Matrix (Option Pos)) Pos Pos -> (Matrix (Option Pos)))) (define change-cavity (lambda (cave pos new-cavity-id) (let ((i (car pos)) (j (cdr pos))) (change-cavity-aux cave pos new-cavity-id (matrix-read cave i j))))) -(: change-cavity-aux ((Matrix Pos) Pos Pos Pos -> (Matrix Pos))) +(: change-cavity-aux ((Matrix (Option Pos)) Pos Pos (Option Pos) + -> (Matrix (Option Pos)))) (define change-cavity-aux (lambda (cave pos new-cavity-id old-cavity-id) (let ((i (car pos)) (j (cdr pos))) (let ((cavity-id (matrix-read cave i j))) (if (equal? cavity-id old-cavity-id) - (foldl (lambda: ((c : (Matrix Pos)) (nc : Pos)) + (foldl (lambda: ((c : (Matrix (Option Pos))) (nc : Pos)) (change-cavity-aux c nc new-cavity-id old-cavity-id)) (matrix-write cave i j new-cavity-id) (neighboring-cavities pos cave)) diff --git a/collects/tests/racket/benchmarks/common/paraffins-typed.rktl b/collects/tests/racket/benchmarks/common/paraffins-typed.rktl index bfa3d15b54..c4b359dc3e 100644 --- a/collects/tests/racket/benchmarks/common/paraffins-typed.rktl +++ b/collects/tests/racket/benchmarks/common/paraffins-typed.rktl @@ -1,7 +1,5 @@ ;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms. -(require/typed scheme/base (collect-garbage ( -> Void))) - (define-type Radical (Rec Radical (U 'C 'H 'BCP 'CCP (Vectorof Radical)))) (: gen (Integer -> (Vectorof (Listof Radical)))) diff --git a/collects/tests/racket/benchmarks/common/puzzle-typed.rktl b/collects/tests/racket/benchmarks/common/puzzle-typed.rktl index 1addc1b3e3..9bfe2f8d61 100644 --- a/collects/tests/racket/benchmarks/common/puzzle-typed.rktl +++ b/collects/tests/racket/benchmarks/common/puzzle-typed.rktl @@ -89,14 +89,14 @@ (+ (vector-ref *piececount* (vector-ref *class* i)) 1)))) -(: trial (Integer -> Boolean)) +(: trial (Integer -> Any)) (define (trial j) (let: ((k : Integer 0)) (call-with-current-continuation (lambda: ((return : (Boolean -> Nothing))) - (do: : Boolean + (do: : Any ((i : Integer 0 (+ i 1))) - ((> i typemax) (set! *kount* (+ *kount* 1)) #f) + ((> i typemax) (set! *kount* (+ *kount* 1)) '()) (cond ((not (zero? @@ -123,15 +123,15 @@ (: definePiece (Integer Integer Integer Integer -> Void)) (define (definePiece iclass ii jj kk) (let: ((index : Integer 0)) - (do: : Null + (do: : Void ((i : Integer 0 (+ i 1))) - ((> i ii) '()) - (do: : Null + ((> i ii)) + (do: : Void ((j : Integer 0 (+ j 1))) - ((> j jj) '()) - (do: : Null + ((> j jj)) + (do: : Void ((k : Integer 0 (+ k 1))) - ((> k kk) '()) + ((> k kk)) (set! index (+ i (* *d* (+ j (* *d* k))))) (vector-set! (vector-ref *p* *iii*) index #t)))) (vector-set! *class* *iii* iclass) From 40c77586a059efc6a09a6ef0bdf73a35808f24b0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 26 May 2010 19:13:08 -0400 Subject: [PATCH 33/52] Better type for `round'. --- .../typed-scheme/private/base-env-numeric.rkt | 20 ++++++------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index c80d9ad658..61becebd5e 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -19,6 +19,8 @@ (define-for-syntax binop (lambda (t [r t]) (t t . -> . r))) + (define-for-syntax rounder + (cl->* (-> -ExactRational -Integer) (-> -Flonum -Flonum) (-> -Real -Real))) (define-for-syntax (unop t) (-> t t)) @@ -112,18 +114,10 @@ (-Real . -> . -ExactRational) (N . -> . N))] -[floor (cl->* - (-> -ExactRational -Integer) - (-> -Flonum -Flonum) - (-> -Real -Real))] -[ceiling (cl->* - (-> -ExactRational -Integer) - (-> -Flonum -Flonum) - (-> -Real -Real))] -[truncate (cl->* - (-> -ExactRational -Integer) - (-> -Flonum -Flonum) - (-> -Real -Real))] +[floor rounder] +[ceiling rounder] +[truncate rounder] +[round rounder] [make-rectangular (-Real -Real . -> . N)] [make-polar (-Real -Real . -> . N)] [real-part (N . -> . -Real)] @@ -150,8 +144,6 @@ [gcd (null -Integer . ->* . -Integer)] [lcm (null -Integer . ->* . -Integer)] -[round (-Real . -> . -Real)] - ;; scheme/math [sgn (-Real . -> . -Real)] From d4a8c52c7102778e6b1ef8fae8b5c75774069487 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 26 May 2010 19:13:19 -0400 Subject: [PATCH 34/52] Fix error message for multiple values. --- collects/typed-scheme/typecheck/tc-app-helper.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-app-helper.rkt b/collects/typed-scheme/typecheck/tc-app-helper.rkt index a2c7457cc2..d829d63260 100644 --- a/collects/typed-scheme/typecheck/tc-app-helper.rkt +++ b/collects/typed-scheme/typecheck/tc-app-helper.rkt @@ -1,13 +1,14 @@ #lang scheme/base (require "../utils/utils.rkt" scheme/match unstable/list - (utils tc-utils) (rep type-rep) (types utils union)) + (utils tc-utils) (rep type-rep) (types utils union abbrev)) (provide (all-defined-out)) (define (make-printable t) (match t [(tc-result1: t) t] + [(tc-results: ts) (-values ts)] [_ t])) (define (stringify-domain dom rst drst [rng #f]) From 63dbde1e9eff5cf7b4d2965a6d26fbc2dc7280e9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 10:05:56 -0400 Subject: [PATCH 35/52] Fix test for new `do:' behavior. --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 67d520a89d..75a4d03601 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -62,6 +62,7 @@ [(_ e) #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] + [custom-printer #f] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) (find-mutated-vars ex) @@ -72,6 +73,7 @@ [(_ e) #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] + [custom-printer #f] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) (find-mutated-vars ex) @@ -611,7 +613,7 @@ (do: : Number ((x : (Listof Number) x (cdr x)) (sum : Number 0 (+ sum (car x)))) ((null? x) sum))) - N] + #:ret (ret N (-FS -top -top) (make-NoObject))] [tc-e/t (if #f 1 'foo) (-val 'foo)] From bd0bcda85e0526e22b31a8dd64dbaf083d0d992a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 10:50:15 -0400 Subject: [PATCH 36/52] Simpler has-name? implementation. --- collects/typed-scheme/types/printer.rkt | 26 +++++++++---------------- 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 122e6f0c65..15043f5548 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -1,9 +1,8 @@ #lang scheme/base -(require "../utils/utils.rkt") -(require (rep type-rep filter-rep object-rep rep-utils) - (utils tc-utils) - scheme/match) +(require unstable/sequence racket/require racket/match + (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" + "rep/rep-utils.rkt" "utils/utils.rkt" "utils/tc-utils.rkt")) ;; do we attempt to find instantiations of polymorphic types to print? ;; FIXME - currently broken @@ -18,16 +17,10 @@ ;; does t have a type name associated with it currently? ;; has-name : Type -> Maybe[Symbol] (define (has-name? t) - (define ns ((current-type-names))) - (let/ec return - (unless print-aliases - (return #f)) - (for-each - (lambda (pair) - (cond [(eq? t (cdr pair)) - (return (car pair))])) - ns) - #f)) + (and print-aliases + (for/first ([(n t*) (in-pairs (in-list ((current-type-names))))] + #:when (type-equal? t t*)) + n))) (define (print-filter c port write?) (define (fp . args) (apply fprintf port args)) @@ -126,9 +119,8 @@ [(Univ:) (fp "Any")] ;; special case number until something better happens ;;[(Base: 'Number _) (fp "Number")] - [(? has-name?) - #;(printf "has a name\n") - (fp "~a" (has-name? c))] + [(app has-name? (? values name)) + (fp "~a" name)] [(StructTop: st) (fp "~a" st)] [(BoxTop:) (fp "Box")] [(VectorTop:) (fp "Vector")] From 9701ae0065dbc54f36059b20a78a917a20ae18e5 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 10:50:33 -0400 Subject: [PATCH 37/52] Avoid requiring old base-types. --- .../tests/typed-scheme/unit-tests/type-annotation-test.rkt | 4 ++-- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 2 -- collects/typed-scheme/private/prims.rkt | 2 +- collects/typed-scheme/private/with-types.rkt | 1 - collects/typed-scheme/typed-scheme.rkt | 2 +- 5 files changed, 4 insertions(+), 7 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt b/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt index 5acdeb0b18..a1c19804d8 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt @@ -17,7 +17,7 @@ [ns (make-base-namespace)]) (parameterize ([current-namespace ns]) (namespace-require 'typed-scheme/private/prims) - (namespace-require 'typed-scheme/private/base-types) + (namespace-require 'typed-scheme/private/base-types-new) (namespace-require 'typed-scheme/private/base-types-extra) (expand 'ann-stx)))) ty)) @@ -26,7 +26,7 @@ (test-suite "Type Annotation tests" ;; FIXME - ask Ryan - ;(tat (ann foo : Number) (ret -Number)) + (tat (ann foo : Number) (ret -Number)) (tat foo #f) (tat (ann foo : 3) (ret (-val 3) (make-NoFilter) (make-NoObject))))) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 75a4d03601..f46fb27d31 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -62,7 +62,6 @@ [(_ e) #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] - [custom-printer #f] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) (find-mutated-vars ex) @@ -73,7 +72,6 @@ [(_ e) #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] - [custom-printer #f] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) (find-mutated-vars ex) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index 71c632d711..e2582ca6b0 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -48,7 +48,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (except-in mzlib/contract ->) (only-in mzlib/contract [-> c->]) mzlib/struct - "base-types.rkt" + "base-types-new.rkt" "base-types-extra.rkt") (define-for-syntax (ignore stx) (syntax-property stx 'typechecker:ignore #t)) diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt index 52b506a54a..29d30b1064 100644 --- a/collects/typed-scheme/private/with-types.rkt +++ b/collects/typed-scheme/private/with-types.rkt @@ -8,7 +8,6 @@ "base-env-indexing-old.rkt" "extra-procs.rkt" "prims.rkt" - "base-types.rkt" racket/contract/regions racket/contract/base (for-syntax "base-types-extra.rkt" diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 1ffb4a199b..615cc6b489 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -2,7 +2,7 @@ (require (rename-in "utils/utils.rkt" [infer r:infer])) -(require (private base-types with-types) +(require (private with-types) (for-syntax (except-in syntax/parse id) scheme/base From 34fef6e53875e5aad3dac947ae7eaf339c2d163f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 12:46:29 -0400 Subject: [PATCH 38/52] Re-enable test. --- .../tests/typed-scheme/unit-tests/type-annotation-test.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt b/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt index a1c19804d8..cb6bd5aaa3 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt @@ -26,10 +26,12 @@ (test-suite "Type Annotation tests" ;; FIXME - ask Ryan - (tat (ann foo : Number) (ret -Number)) + (tat (ann foo : Number) (ret -Number (make-NoFilter) (make-NoObject))) (tat foo #f) (tat (ann foo : 3) (ret (-val 3) (make-NoFilter) (make-NoObject))))) (define-go type-annotation-tests) + + From 8194bcc4d41c79c39cb0a4a13a810f2b6bbc35d3 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 12:46:37 -0400 Subject: [PATCH 39/52] Guard type-equal? test. --- collects/typed-scheme/types/printer.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 15043f5548..ba99133337 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -19,7 +19,7 @@ (define (has-name? t) (and print-aliases (for/first ([(n t*) (in-pairs (in-list ((current-type-names))))] - #:when (type-equal? t t*)) + #:when (and (Type? t*) (type-equal? t t*))) n))) (define (print-filter c port write?) From 103d53f6adce4965b4d948475cadd97546faf511 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 10:38:15 -0600 Subject: [PATCH 40/52] Correcting default help desc --- collects/meta/drdr/render.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/drdr/render.ss b/collects/meta/drdr/render.ss index ba8aa97253..29328d2ea8 100644 --- a/collects/meta/drdr/render.ss +++ b/collects/meta/drdr/render.ss @@ -480,7 +480,7 @@ @h1{How is the push "tested"?} @p{Each file's @code{@,PROP:command-line} property is consulted. If it is the empty string, the file is ignored. If it is a string, then a single @code{~s} is replaced with the file's path, @code{racket} and @code{mzc} with their path (for the current push), and @code{gracket} and @code{gracket-text} with @code{gracket-text}'s path (for the current push); then the resulting command-line is executed. (Currently no other executables are allowed, so you can't @code{rm -fr /}.) - If there is no property value, the default (@code{mzscheme -t ~s}) is used if the file's suffix is @code{.ss}, @code{.scm}, or @code{.scrbl}.} + If there is no property value, the default @code{racket -qt ~s} is used if the file's suffix is @code{.rkt}, @code{.ss}, @code{.scm}, or @code{.scrbl} and @code{racket -f ~s} is used if the file's suffix is @code{.rktl}.} @p{The command-line is always executed with a fresh empty current directory which is removed after the run. But all the files share the same home directory and X server, which are both removed after each push's testing is complete.} From 08a48a67a094a04bdaa15363cc3d77a202cc4580 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 10:48:05 -0600 Subject: [PATCH 41/52] Making string->xexpr more permissive --- collects/tests/xml/test.rkt | 29 ++++++++++++++++++++--------- collects/xml/private/xexpr.rkt | 2 +- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/collects/tests/xml/test.rkt b/collects/tests/xml/test.rkt index 0df3754318..cbf56eb0af 100644 --- a/collects/tests/xml/test.rkt +++ b/collects/tests/xml/test.rkt @@ -481,7 +481,10 @@ END [(define (test-xml->xexpr str xe) (test-equal? str (string->xexpr str) xe)) (define (test-xexpr->string xe str) - (test-equal? (format "~S" xe) (xexpr->string xe) str))] + (test-equal? (format "~S" xe) (xexpr->string xe) str) + (test-string->xexpr str xe)) + (define (test-string->xexpr str xe) + (test-equal? str (string->xexpr str) xe))] (test-suite "XML and X-expression Conversions" @@ -519,12 +522,20 @@ END ; XXX more xexpr->string tests ) + (test-suite + "string->xexpr" + (test-string->xexpr "\n\n\n" + '(html ())) + (parameterize ([xexpr-drop-empty-attributes #t]) + (test-string->xexpr "\n\n\n" + '(html)))) + (local [(define (test-eliminate-whitespace tags choose str res) (test-equal? (format "~S" (list tags choose str)) (with-output-to-string - (lambda () - (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str)))))) + (lambda () + (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str)))))) res)) (define (test-eliminate-whitespace/exn tags choose str msg) (test-exn (format "~S" (list tags choose str)) @@ -533,8 +544,8 @@ END (regexp-match (regexp-quote msg) (exn-message x)))) (lambda () (with-output-to-string - (lambda () - (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str))))))))) + (lambda () + (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str))))))))) (define (truer x) #t)] (test-suite "eliminate-whitespace" @@ -601,8 +612,8 @@ END (test-equal? (format "~S" (list v istr)) (parameterize ([param v]) (with-output-to-string - (lambda () - (write-xml (read-xml (open-input-string istr)))))) + (lambda () + (write-xml (read-xml (open-input-string istr)))))) ostr)) (define test-empty-tag-shorthand (mk-test-param empty-tag-shorthand)) (define test-collapse-whitespace (mk-test-param collapse-whitespace)) @@ -715,8 +726,8 @@ END (test-equal? "write-plist" (with-output-to-string - (lambda () - (write-plist example (current-output-port)))) + (lambda () + (write-plist example (current-output-port)))) example-str) (local [(define (test-plist-round-trip plist) diff --git a/collects/xml/private/xexpr.rkt b/collects/xml/private/xexpr.rkt index 03b84eb710..ef7a65815f 100644 --- a/collects/xml/private/xexpr.rkt +++ b/collects/xml/private/xexpr.rkt @@ -233,7 +233,7 @@ (get-output-string port))) (define (string->xexpr str) - (xml->xexpr (read-xml/element (open-input-string str)))) + (xml->xexpr (document-element (read-xml (open-input-string str))))) ;; bcompose : (a a -> c) (b -> a) -> (b b -> c) (define (bcompose f g) From 612bd22bfe88dcfa27d133c6572a42cff406a6dd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 12:20:16 -0600 Subject: [PATCH 42/52] Cyclic zo tests --- collects/tests/compiler/zo-exs.rkt | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 collects/tests/compiler/zo-exs.rkt diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt new file mode 100644 index 0000000000..b8ab07e067 --- /dev/null +++ b/collects/tests/compiler/zo-exs.rkt @@ -0,0 +1,22 @@ +#lang racket +(require compiler/zo-parse + compiler/zo-marshal + tests/eli-tester) + +(define (roundtrip ct) + (define bs (zo-marshal ct)) + (test bs + (zo-parse (open-input-bytes bs)) => ct)) + +(test + (local [(define (hash-test make-hash-placeholder) + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (local [(define ht-ph (make-placeholder #f)) + (define ht (make-hash-placeholder (list (cons 'g ht-ph))))] + (placeholder-set! ht-ph ht) + (make-reader-graph ht)))))] + (hash-test make-hash-placeholder) + (hash-test make-hasheq-placeholder) + (hash-test make-hasheqv-placeholder))) From 5833f7cba49dcf780684d5144ce152a948231bf9 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 11:59:41 -0600 Subject: [PATCH 43/52] Unifying some code --- collects/compiler/zo-parse.rkt | 90 ++++++++++++---------------------- 1 file changed, 30 insertions(+), 60 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 6f1b338560..b6596c91b8 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -501,15 +501,9 @@ ;; ---------------------------------------- ;; Syntax unmarshaling - (define (decode-stx cp v) (if (integer? v) - (let-values ([(v2 decoded?) (unmarshal-stx-get cp v)]) - (if decoded? - v2 - (let ([v2 (decode-stx cp v2)]) - (unmarshal-stx-set! cp v v2) - v2))) + (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) (let-values ([(cert-marks v encoded-wraps) (match v @@ -569,24 +563,14 @@ (define (decode-wraps cp w) ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) (if (integer? w) - (let-values ([(w2 decoded?) (unmarshal-stx-get cp w)]) - (if decoded? - w2 - (let ([w2 (decode-wraps cp w2)]) - (unmarshal-stx-set! cp w w2) - w2))) + (unmarshal-stx-get/decode cp w decode-wraps) (map (lambda (a) (let aloop ([a a]) ; A wrap-elem is either (cond ; A reference [(integer? a) - (let-values ([(a2 decoded?) (unmarshal-stx-get cp a)]) - (if decoded? - a2 - (let ([a2 (aloop a2)]) - (unmarshal-stx-set! cp a a2) - a2)))] + (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] ; A mark (not actually a number as the C says, but a (list ) [(and (pair? a) (null? (cdr a)) (number? (car a))) (make-wrap-mark (car a))] @@ -704,22 +688,15 @@ [module-path-index (make-simple-module-binding module-path-index)])))) -(define (unmarshal-stx-get cp pos) - (if (pos . >= . (vector-length (cport-symtab cp))) - (values `(#%bad-index ,pos) #t) - (let ([v (vector-ref (cport-symtab cp) pos)]) - (if (not-ready? v) - (let ([save-pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos))) - (let ([v (read-compact cp)]) - (vector-set! (cport-symtab cp) pos v) - (set-cport-pos! cp save-pos) - (values v #f))) - (values v (vector-ref (cport-decoded cp) pos)))))) - -(define (unmarshal-stx-set! cp pos v) - (vector-set! (cport-symtab cp) pos v) - (vector-set! (cport-decoded cp) pos #t)) +(define (unmarshal-stx-get/decode cp pos decode-stx) + (define v2 (read-sym cp pos)) + (define decoded? (vector-ref (cport-decoded cp) pos)) + (if decoded? + v2 + (let ([dv2 (decode-stx cp v2)]) + (vector-set! (cport-symtab cp) pos dv2) + (vector-set! (cport-decoded cp) pos #t) + dv2))) (define (parse-module-path-index cp s) s) @@ -738,15 +715,7 @@ (case cpt-tag [(delayed) (let ([pos (read-compact-number cp)]) - (let ([v (vector-ref (cport-symtab cp) pos)]) - (if (not-ready? v) - (let ([save-pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos))) - (let ([v (read-compact cp)]) - (vector-set! (cport-symtab cp) pos v) - (set-cport-pos! cp save-pos) - v)) - v)))] + (read-sym cp pos))] [(escape) (let* ([len (read-compact-number cp)] [s (cport-get-bytes cp len)]) @@ -894,16 +863,8 @@ (read-compact cp))))]) (read (open-input-bytes #"x")))))] [(symref) - (let* ([l (read-compact-number cp)] - [v (vector-ref (cport-symtab cp) l)]) - (if (not-ready? v) - (let ([pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l))) - (let ([v (read-compact cp)]) - (set-cport-pos! cp pos) - (vector-set! (cport-symtab cp) l v) - v)) - v))] + (let* ([l (read-compact-number cp)]) + (read-sym cp l))] [(weird-symbol) (let ([uninterned (read-compact-number cp)] [str (read-compact-chars cp (read-compact-number cp))]) @@ -956,6 +917,17 @@ [else (cons v (loop (sub1 need-car) proper))])))) +(define (read-sym cp i) + (define symtab (cport-symtab cp)) + (define vv (vector-ref symtab i)) + (define save-pos (cport-pos cp)) + (when (not-ready? vv) + (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) + (let ([v (read-compact cp)]) + (vector-set! symtab i v)) + (set-cport-pos! cp save-pos)) + (vector-ref symtab i)) + ;; path -> bytes ;; implementes read.c:read_compiled (define (zo-parse port) @@ -990,16 +962,14 @@ (unless (eof-object? (read-byte port)) (error 'zo-parse "File too big")) - (define symtab (make-vector symtabsize (make-not-ready))) + (define nr (make-not-ready)) + (define symtab + (make-vector symtabsize nr)) (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) - (define vv (vector-ref symtab i)) - (when (not-ready? vv) - (set-cport-pos! cp (vector-ref so* (sub1 i))) - (let ([v (read-compact cp)]) - (vector-set! symtab i v)))) + (read-sym cp i)) (set-cport-pos! cp shared-size) (read-marshalled 'compilation-top-type cp))) From 40884483176778b26d6444100d1c997b9e8961cd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 11:59:55 -0600 Subject: [PATCH 44/52] Dealing with cyclic hashes --- collects/compiler/zo-marshal.rkt | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 5fbf347c94..f3ee228f9d 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -228,6 +228,11 @@ (traverse-stx expr visit)] [(wrapped? expr) (traverse-wrapped expr visit)] + [(hash? expr) + (when (visit expr) + (for ([(k v) (in-hash expr)]) + (traverse-data k visit) + (traverse-data v visit)))] [else (void)])) @@ -987,16 +992,18 @@ (for ([v (in-vector expr)]) (out-data v out))] [(hash? expr) - (out-byte CPT_HASH_TABLE out) - (out-number (cond - [(hash-eqv? expr) 2] - [(hash-eq? expr) 0] - [else 1]) - out) - (out-number (hash-count expr) out) - (for ([(k v) (in-hash expr)]) - (out-data k out) - (out-data v out))] + (out-shared expr out + (lambda () + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? expr) 2] + [(hash-eq? expr) 0] + [else 1]) + out) + (out-number (hash-count expr) out) + (for ([(k v) (in-hash expr)]) + (out-data k out) + (out-data v out))))] [(svector? expr) (let* ([vec (svector-vec expr)] [len (vector-length vec)]) From 035ee93911901636d7dc87a83e991dd4290386e5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 12:13:13 -0600 Subject: [PATCH 45/52] Using placeholders in zo-parse for more cyclic datums --- collects/compiler/zo-parse.rkt | 58 +++++++++++++----------- collects/compiler/zo-structs.rkt | 4 +- collects/scribblings/raco/zo-parse.scrbl | 2 +- 3 files changed, 34 insertions(+), 30 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index b6596c91b8..4d97023a90 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -15,8 +15,6 @@ Lines 628, 630 seem to be only for debugging and should probably throw errors - unmarshal-stx-get also seems to be for debugging and should probably throw an error - vector and pair cases of decode-wraps seem to do different things from the corresponding C code Line 816: This should be an eqv placeholder (but they don't exist) @@ -29,8 +27,6 @@ collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (# 0 (1363072) . #f) --- that doesn't seem to match the spec - We seem to leave placeholders for hash-tables in the structs - |# ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -558,8 +554,6 @@ (map loop (cdr (vector->list (struct->vector v)))))))] [else (add-wrap v)])))))) - - (define (decode-wraps cp w) ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) (if (integer? w) @@ -688,16 +682,6 @@ [module-path-index (make-simple-module-binding module-path-index)])))) -(define (unmarshal-stx-get/decode cp pos decode-stx) - (define v2 (read-sym cp pos)) - (define decoded? (vector-ref (cport-decoded cp) pos)) - (if decoded? - v2 - (let ([dv2 (decode-stx cp v2)]) - (vector-set! (cport-symtab cp) pos dv2) - (vector-set! (cport-decoded cp) pos #t) - dv2))) - (define (parse-module-path-index cp s) s) ;; ---------------------------------------- @@ -895,7 +879,7 @@ [(closure) (let* ([l (read-compact-number cp)] [ind (make-indirect #f)]) - (vector-set! (cport-symtab cp) l ind) + (placeholder-set! (vector-ref (cport-symtab cp) l) ind) (let* ([v (read-compact cp)] [cl (make-closure v (gensym (let ([s (lam-name v)]) @@ -917,16 +901,35 @@ [else (cons v (loop (sub1 need-car) proper))])))) +(define (unmarshal-stx-get/decode cp pos decode-stx) + (define v2 (read-sym cp pos)) + (define decoded? (vector-ref (cport-decoded cp) pos)) + (if decoded? + v2 + (let ([dv2 (decode-stx cp v2)]) + (placeholder-set! (vector-ref (cport-symtab cp) pos) dv2) + (vector-set! (cport-decoded cp) pos #t) + dv2))) + +(require unstable/markparam) +(define read-sym-mark (mark-parameter)) (define (read-sym cp i) (define symtab (cport-symtab cp)) - (define vv (vector-ref symtab i)) - (define save-pos (cport-pos cp)) - (when (not-ready? vv) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) - (let ([v (read-compact cp)]) - (vector-set! symtab i v)) - (set-cport-pos! cp save-pos)) - (vector-ref symtab i)) + (define ph (vector-ref symtab i)) + ; We are reading this already, so return the placeholder + (if (memq i (mark-parameter-all read-sym-mark)) + ph + ; Otherwise, try to read it and return the real thing + (local [(define vv (placeholder-get ph))] + (when (not-ready? vv) + (local [(define save-pos (cport-pos cp))] + (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) + (mark-parameterize + ([read-sym-mark i]) + (let ([v (read-compact cp)]) + (placeholder-set! ph v))) + (set-cport-pos! cp save-pos))) + (placeholder-get ph)))) ;; path -> bytes ;; implementes read.c:read_compiled @@ -964,14 +967,15 @@ (define nr (make-not-ready)) (define symtab - (make-vector symtabsize nr)) + (build-vector symtabsize (λ (i) (make-placeholder nr)))) (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) (read-sym cp i)) (set-cport-pos! cp shared-size) - (read-marshalled 'compilation-top-type cp))) + (make-reader-graph + (read-marshalled 'compilation-top-type cp)))) ;; ---------------------------------------- diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 2d2413594d..7c3e317bd4 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -22,7 +22,7 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin - (define-struct id+par (field-id ...) #:transparent) + (define-struct id+par (field-id ...) #:prefab) (provide/contract [struct id ([field-id field-contract] ...)]))) @@ -57,7 +57,7 @@ (define-form-struct (expr form) ()) ;; A static closure can refer directly to itself, creating a cycle -(define-struct indirect ([v #:mutable]) #:transparent) +(define-struct indirect ([v #:mutable]) #:prefab) (define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this diff --git a/collects/scribblings/raco/zo-parse.scrbl b/collects/scribblings/raco/zo-parse.scrbl index 2f696e0fd6..cf38af3365 100644 --- a/collects/scribblings/raco/zo-parse.scrbl +++ b/collects/scribblings/raco/zo-parse.scrbl @@ -5,7 +5,7 @@ compiler/zo-parse)) @(define-syntax-rule (defstruct+ id fields . rest) - (defstruct id fields #:transparent . rest)) + (defstruct id fields #:prefab . rest)) @title{API for Parsing Bytecode} From 7e485b8d28a43581c501c0f16e62e7b67f494324 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 12:19:58 -0600 Subject: [PATCH 46/52] Documenting make-hasheqv and using it --- collects/compiler/zo-parse.rkt | 3 +-- collects/scribblings/reference/pairs.scrbl | 6 ++++++ 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 4d97023a90..c7f6670fc3 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -794,9 +794,8 @@ [len (read-compact-number cp)]) ((case eq [(0) make-hasheq-placeholder] - ; XXX One of these should be eqv [(1) make-hash-placeholder] - [(2) make-hash-placeholder]) + [(2) make-hasheqv-placeholder]) (for/list ([i (in-range len)]) (cons (read-compact cp) (read-compact cp)))))] diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index b6234dd27f..5c7b6893db 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -1051,3 +1051,9 @@ for use with @scheme[make-reader-graph].} Like @scheme[make-immutable-hasheq], but produces a table placeholder for use with @scheme[make-reader-graph].} + +@defproc[(make-hasheqv-placeholder [assocs (listof pair?)]) + hash-placeholder?]{ + +Like @scheme[make-immutable-hasheqv], but produces a table placeholder +for use with @scheme[make-reader-graph].} From b3fab5cabeaa32832838984362e3fdbe26eb379d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 May 2010 12:48:09 -0600 Subject: [PATCH 47/52] fix MzCOM for Racket Merge to v5.0 --- src/mzcom/mzobj.cxx | 21 ++++++++++++++++----- src/mzcom/mzobj.h | 2 -- src/racket/include/scheme.h | 3 +++ src/racket/src/salloc.c | 10 +++++----- src/racket/src/thread.c | 14 ++++++++++++-- 5 files changed, 36 insertions(+), 14 deletions(-) diff --git a/src/mzcom/mzobj.cxx b/src/mzcom/mzobj.cxx index 0059be7dc6..87350bd7e9 100644 --- a/src/mzcom/mzobj.cxx +++ b/src/mzcom/mzobj.cxx @@ -53,6 +53,8 @@ static Scheme_Object *exn_catching_apply; static Scheme_Object *exn_p; static Scheme_Object *exn_message; +static Scheme_At_Exit_Callback_Proc at_exit_callback; + /* This indirection lets us delayload libmzsch.dll: */ #define scheme_false (scheme_make_false()) @@ -120,8 +122,9 @@ OLECHAR *wideStringFromSchemeObj(Scheme_Object *obj,char *fmt,int fmtlen) { } void exitHandler(int) { + if (at_exit_callback) at_exit_callback(); ReleaseSemaphore(exitSem,1,NULL); - ExitThread(0); + _endthreadex(0); } void setupSchemeEnv(Scheme_Env *in_env) @@ -143,7 +146,7 @@ void setupSchemeEnv(Scheme_Env *in_env) if (env == NULL) { ErrorBox("Can't create Scheme environment"); - ExitThread(0); + _endthreadex(0); } // set up collection paths, based on Racket startup @@ -294,7 +297,16 @@ static int do_evalLoop(Scheme_Env *env, int argc, char **_args) return 0; } -DWORD WINAPI evalLoop(LPVOID args) { +static void record_at_exit(Scheme_At_Exit_Callback_Proc p) XFORM_SKIP_PROC +{ + at_exit_callback = p; +} + +static __declspec(thread) void *tls_space; + +static unsigned WINAPI evalLoop(void *args) XFORM_SKIP_PROC { + scheme_register_tls_space(&tls_space, 0); + scheme_set_atexit(record_at_exit); return scheme_main_setup(1, do_evalLoop, 0, (char **)args); } @@ -312,14 +324,13 @@ void CMzObj::startMzThread(void) { tg.resetDoneSem = resetDoneSem; tg.pErrorState = &errorState; - threadHandle = CreateThread(NULL,0,evalLoop,(LPVOID)&tg,0,&threadId); + threadHandle = (HANDLE)_beginthreadex(NULL, 0, evalLoop, &tg, 0, NULL); } CMzObj::CMzObj(void) { inputMutex = NULL; readSem = NULL; - threadId = NULL; threadHandle = NULL; inputMutex = CreateSemaphore(NULL,1,1,NULL); diff --git a/src/mzcom/mzobj.h b/src/mzcom/mzobj.h index bd6f0e96e0..5d99f57ebd 100644 --- a/src/mzcom/mzobj.h +++ b/src/mzcom/mzobj.h @@ -19,7 +19,6 @@ typedef struct { } THREAD_GLOBALS; extern HINSTANCE globHinst; -extern DWORD WINAPI evalLoop(LPVOID); ///////////////////////////////////////////////////////////////////////////// // CMzObj @@ -47,7 +46,6 @@ class ATL_NO_VTABLE CMzObj : HANDLE evalDoneSems[2]; BSTR *globInput; BSTR globOutput; - DWORD threadId; HANDLE threadHandle; BOOL errorState; diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 537ce30aa1..0757c94248 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -1719,6 +1719,9 @@ MZ_EXTERN void scheme_set_current_thread_ran_some(); typedef void (*Scheme_Exit_Proc)(int v); MZ_EXTERN Scheme_Exit_Proc scheme_exit; MZ_EXTERN void scheme_set_exit(Scheme_Exit_Proc p); +typedef void (*Scheme_At_Exit_Callback_Proc)(); +typedef void (*Scheme_At_Exit_Proc)(Scheme_At_Exit_Callback_Proc); +MZ_EXTERN void scheme_set_atexit(Scheme_At_Exit_Proc p); typedef void (*scheme_console_printf_t)(char *str, ...); MZ_EXTERN scheme_console_printf_t scheme_console_printf; MZ_EXTERN scheme_console_printf_t scheme_get_console_printf(); diff --git a/src/racket/src/salloc.c b/src/racket/src/salloc.c index 0229d0ea2b..6d95e44d6d 100644 --- a/src/racket/src/salloc.c +++ b/src/racket/src/salloc.c @@ -103,7 +103,7 @@ struct free_list_entry { THREAD_LOCAL_DECL(static struct free_list_entry *free_list;) THREAD_LOCAL_DECL(static int free_list_bucket_count;) -void scheme_set_stack_base(void *base, int no_auto_statics) +void scheme_set_stack_base(void *base, int no_auto_statics) XFORM_SKIP_PROC { #ifdef MZ_PRECISE_GC GC_init_type_tags(_scheme_last_type_, @@ -162,7 +162,7 @@ static int call_with_basic(void *data) return _main(scheme_basic_env(), ma->argc, ma->argv); } -int scheme_main_setup(int no_auto_statics, Scheme_Env_Main _main, int argc, char **argv) +int scheme_main_setup(int no_auto_statics, Scheme_Env_Main _main, int argc, char **argv) XFORM_SKIP_PROC { Scheme_Main_Data d; d._main = _main; @@ -171,7 +171,7 @@ int scheme_main_setup(int no_auto_statics, Scheme_Env_Main _main, int argc, char return scheme_main_stack_setup(no_auto_statics, call_with_basic, &d); } -static int do_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) +static int do_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) { void *stack_start; int volatile return_code; @@ -281,7 +281,7 @@ int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void return do_main_stack_setup(no_auto_statics, _main, data); } -void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics) +void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics) XFORM_SKIP_PROC { scheme_set_stack_base(base, no_auto_statics); @@ -292,7 +292,7 @@ void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics) #endif } -extern unsigned long scheme_get_stack_base() +extern unsigned long scheme_get_stack_base() XFORM_SKIP_PROC { #if !defined(MZ_PRECISE_GC) && !defined(USE_SENORA_GC) if (GC_stackbottom) diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index 0010a56c38..eeaae7893f 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -184,6 +184,7 @@ extern int GC_is_marked(void *); # endif #endif +READ_ONLY Scheme_At_Exit_Proc replacement_at_exit; ROSYM Scheme_Object *scheme_parameterization_key; ROSYM Scheme_Object *scheme_exn_handler_key; @@ -1942,14 +1943,23 @@ static void run_atexit_closers(void) scheme_current_thread->error_buf = savebuf; } +void scheme_set_atexit(Scheme_At_Exit_Proc p) +{ + replacement_at_exit = p; +} + void scheme_add_atexit_closer(Scheme_Exit_Closer_Func f) { if (!cust_closers) { + if (replacement_at_exit) { + replacement_at_exit(run_atexit_closers); + } else { #ifdef USE_ON_EXIT_FOR_ATEXIT - on_exit(run_atexit_closers, NULL); + on_exit(run_atexit_closers, NULL); #else - atexit(run_atexit_closers); + atexit(run_atexit_closers); #endif + } REGISTER_SO(cust_closers); cust_closers = scheme_null; From 6006a4c84d6e2b81fe1a9209f596fdcebd6e7734 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 May 2010 06:36:45 -0600 Subject: [PATCH 48/52] fix helper file for raco ctool test --- collects/tests/racket/makeflats.rktl | 50 ++++++++++++++-------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/collects/tests/racket/makeflats.rktl b/collects/tests/racket/makeflats.rktl index d4145c883d..33bc3f5740 100644 --- a/collects/tests/racket/makeflats.rktl +++ b/collects/tests/racket/makeflats.rktl @@ -4,32 +4,32 @@ (let ([ns (current-namespace)]) (parameterize ([current-namespace (make-base-namespace)]) (set! flat-number (add1 flat-number)) - (namespace-attach-module ns 'scheme) - (namespace-require 'scheme) + (namespace-attach-module ns 'racket) + (namespace-require 'racket) (eval `(begin (define flat-load ,f) (define flat-number ,(format "-~a" flat-number)) - (load-relative "makeflat.ss")))))) - '("basic.ss" - "unicode.ss" - "read.ss" - "macro.ss" - "syntax.ss" - "stx.ss" - "module.ss" - "number.ss" - "object.ss" - "struct.ss" - "unit.ss" - "unitsig.ss" - "thread.ss" - "sync.ss" - "deep.ss" - "contmark.ss" - "prompt.ss" - "will.ss" - "namespac.ss" - "port.ss" - "file.ss" - "path.ss")) + (load-relative "makeflat.rktl")))))) + '("basic.rktl" + "unicode.rktl" + "read.rktl" + "macro.rktl" + "syntax.rktl" + "stx.rktl" + "module.rktl" + "number.rktl" + "object.rktl" + "struct.rktl" + "unit.rktl" + "unitsig.rktl" + "thread.rktl" + "sync.rktl" + "deep.rktl" + "contmark.rktl" + "prompt.rktl" + "will.rktl" + "namespac.rktl" + "port.rktl" + "file.rktl" + "path.rktl")) From d923ef135fefd1e257cf418a8b2151fd1e40f365 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 May 2010 15:30:00 -0600 Subject: [PATCH 49/52] add examples from J-P Roy's textbook to check before a release --- collects/tests/jpr/README.TXT | 6 ++ collects/tests/jpr/balle-grav-frot.ss | 48 +++++++++++ collects/tests/jpr/ballon.png | Bin 0 -> 4160 bytes collects/tests/jpr/dessine-arbre.ss | 34 ++++++++ collects/tests/jpr/foo.ss | 18 +++++ collects/tests/jpr/jeu-du-chaos.ss | 40 ++++++++++ collects/tests/jpr/mon-script.ss | 30 +++++++ collects/tests/jpr/monte-carlo.ss | 51 ++++++++++++ collects/tests/jpr/streams.ss | 52 ++++++++++++ collects/tests/jpr/valrose.ss | 110 ++++++++++++++++++++++++++ 10 files changed, 389 insertions(+) create mode 100644 collects/tests/jpr/README.TXT create mode 100644 collects/tests/jpr/balle-grav-frot.ss create mode 100644 collects/tests/jpr/ballon.png create mode 100644 collects/tests/jpr/dessine-arbre.ss create mode 100644 collects/tests/jpr/foo.ss create mode 100644 collects/tests/jpr/jeu-du-chaos.ss create mode 100755 collects/tests/jpr/mon-script.ss create mode 100644 collects/tests/jpr/monte-carlo.ss create mode 100644 collects/tests/jpr/streams.ss create mode 100644 collects/tests/jpr/valrose.ss diff --git a/collects/tests/jpr/README.TXT b/collects/tests/jpr/README.TXT new file mode 100644 index 0000000000..deadad3c6d --- /dev/null +++ b/collects/tests/jpr/README.TXT @@ -0,0 +1,6 @@ +Some files to be checked for compatibility with new releases +of PLT-Scheme, from 4.2.5.1 + +Book : "Premiers Cours de Programmation avec (PLT) Scheme" +Jean-Paul Roy, Sept. 2010, 410 pages, to be published. + diff --git a/collects/tests/jpr/balle-grav-frot.ss b/collects/tests/jpr/balle-grav-frot.ss new file mode 100644 index 0000000000..058becac8b --- /dev/null +++ b/collects/tests/jpr/balle-grav-frot.ss @@ -0,0 +1,48 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-advanced-reader.ss" "lang")((modname balle-grav-frot) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t write mixed-fraction #t #t none #f ()))) +;;; Language : advanced student + +(require "valrose.ss") + +(define (balle-avec-gravitation-et-frottement x0 y0 dx0 dy0) + (local [(define BALLE (bitmap "ballon.png")) + (define R (/ (image-width BALLE) 2)) + (define SIZE 400) + (define FOND (place-image (text "Mouse or Space !" 18 "Blue") 200 80 (rectangle SIZE SIZE 'solid "yellow"))) + (define-struct monde (x y dx dy)) + (define INIT (make-monde x0 y0 dx0 dy0)) + (define G #i1) + (define F #i0.95) + (define (suivant m) + (local [(define x (monde-x m)) + (define y (monde-y m)) + (define dx (monde-dx m)) + (define dy (monde-dy m)) + (define xs (+ x dx)) + (define ys (+ y dy))] + (cond ((> ys (- SIZE R)) (make-monde xs (- SIZE R) (* F dx) (+ (* F (- dy)) G))) + ((< xs R) (make-monde R ys (* F (- dx)) (* F (+ dy G)))) + ((> (+ xs R) SIZE) (make-monde (- SIZE R) ys (* F (- dx)) (* F (+ dy G)))) + ((< ys R) (make-monde xs R dx (+ (* F (- dy)) G))) + (else (make-monde xs ys dx (+ dy G)))))) + (define (souris m x y evt) + (if (mouse=? evt "button-down") + (make-monde x y (monde-dx m) (monde-dy m)) + m)) + (define (clavier m key) + (if (key=? key " ") + (make-monde (+ R (random (- SIZE (* 2 R)))) (+ R (random (- SIZE (* 2 R)))) (monde-dx m) (monde-dy m)) + m)) + (define (dessiner m) + (place-image BALLE (monde-x m) (monde-y m) FOND)) + (define (final? m) + (and (< (abs (- SIZE (monde-y m) R)) 1) (< (abs (monde-dx m)) 1) (< (abs (monde-dy m)) 1)))] + (big-bang INIT + (on-tick suivant) + (on-draw dessiner SIZE SIZE) + (on-mouse souris) + (on-key clavier) + (stop-when final?)))) + +(balle-avec-gravitation-et-frottement 200 200 5 15) \ No newline at end of file diff --git a/collects/tests/jpr/ballon.png b/collects/tests/jpr/ballon.png new file mode 100644 index 0000000000000000000000000000000000000000..3f615e55ca830f1d598e2600a8442273c11eb0f0 GIT binary patch literal 4160 zcmV-G5Wnw!wU*XM#+U}6C(sAztJgljW{xaA2i^c)2VMi_ zS!IaYwi6B{5J>o0QLm-(rb@MmS&{&+y>lbt^F*8`u@pUTY3U|0lx>{ z0c^@N2I!PSc6VR|a49f1!gm#LH!!Robz-e87Ytx0;34FRObbFYaHeN{8i1pK7b|4V z27Usx`Nn~Pbi8*1>ob60wcKe1>$n#%7FZXN`xbEcHv$Zx3Ahnhn-K)7mGi^WDg?Fz z9177SotV15n|f^=nBKtyzJ04|Sdoi_nZUmGxhHozY%ntRr?0O(LQ7?FE9 zGe)PkfkCYv4DB0U@&H2JT1Ct~Jr$$Z$|CwOpGuz&EcXb61%|f*F!~_F-Z=ek2ip6R z)qn>w##{~D0(A7jFGB4-^UFf>fcLBXcM9;5F{Zl@LAk*&##{sZ!hlZ+uDtSgAla3ZKXR-MT0Rx!@ zy*>vBUjSDCT^wW`s;%R{z@~KoW1Q+-a~cLQ_hSf$ zMM`<6YuQOrGf@H%gH-Ngj`^d2%my|u6b#^a71j(KRPkR&Hk?KX(n8?a92N5id#~2{y0o!<}pxcz+m=eGkt+I~HP&Nw4 zW!}NiCnXqF{I8a|0A@vim=E;yR6%WkCzbE$0)aSMW!##BM-&iei{Q#UFcWKl-4gOX z5b0BTd#Q!!u3m!D)Ez!gPPaNxusd@@@sJ*1YHVt}K<& zi*S0v+x!sF0hpIPE;W$c`4cOy#UgYuDA} zcGHR)2Arn+rbb$S50AS3O8K6hl((isf=+deLOd&Wwbst9k+(^K+Z5QxTKh^>#yQCt z(-9dyc1K#`-w?CVA(A>)e2@NSHstyhJz%XJ=}}h$JOk{Cyx@LPHFFI_w;?n+iKrse z7#6s`s1{Kn?*jZx#Z;zC3ea_XWH#a6n)zxl_`53i1_|S3pe^tL;zF}oNnjjW5EwQ4 z#T@#ct^5y31qSj?u?EMnHgGZ?J3hyo>roIG4;G|v@W9TXN@rfJ;4P}yD-J@83a~)` zvcOQ;OLJCyT>7M1WqHu|T$S-XCoqtet-zb3YLklOAFg>Pmkh)F2fhTxZ}4A5#xqozryLpoSo7arG7v?Ys37$! zQ2$$1#^C7hm1gQVy}Fv5;d&kGnBNx_X`%uu#8fFgpx0Ac{2D>43u2;H0UaICZHK&> zF9F(qgG^MACKjmwCddo*heSqh(Ux%}(s7Ts)_&oD?l8oa=22_yT8I2z$QZK?uulo1 zhUoqd?_{lAg*ajKK-^$~maaO1iFyDx3QW|4xwT72Wtb?C2lJQ$`3ED_a2`yXO=rYJ zt;TUwgsk8#0~)`9CMrm=?*pFhW3b9tK(K>M{|Kft9(82YU-REnG7x2qqAF7%ep^WE zUZ^tmi}o42>ou*3>gJf=7nNnAqI7x@Osya?MZXS#u+P|8ug^O23cwgzR3}%3j!Vws zolZ8!Y+MlUb$Z$^|~iOgE3|c zU<=?qZ8}xS7}FMUnQ0UG`8;FH?p2ETq>+?wq5?XjAie<@+ZtoG1la^{iJ2>j>2xk8 zzLR?g*s7q8t_L!u?_(!a*0i1kub2$?)d(z($T$pSjoSh@Bosb?aKR}qy^6z|dkSSY zMH~fI))9ng`V#mZo@N_>6D#=t7G%?)1%6$l-~eRWBT3;W$hmhKX}UiL7RB(-vuoB@ zdIQ+g0~nJk_+A6zxnQZ{`37uBx=03hkkZFAB5NcqqZYh|td1QFY>V_&CnK92i>~z5 zz(iz#G6c8*X&n|ZnWKSCGT!IGG4k$(@Qrr&m_nP-azlt~8j}VPz1cv{T4b+W)zvm+ z6!?9_UB@>FOOc&e8|>9X)^BbhY@xG(At{0Aii}z-r-1JFszr zVgrGHY5r#59-wcE8*7JbxXBuMA)1<1=R~h_WNG?NmD{WjpOY&q;z=JTe) z`jdwne3h7;Jcy^_KL|%ik5m_^l$-4!)ZG=fKUtkAS_A4K_hDoq(sse`NGEA%lKX$m!0B#2pFxv2{qR=~t1b zKeGN)O^+22+TCTq5y;!-GLK-yr6&*<(A*$Y+;CgqpDFaX4u3<{_Jodq7BOLWBO}oc zh?S_N%TmY|^C@duL_uyakxDVhp21prtN>0bNd94n?^P6(YMc6_X(7ncUl~BGMyHC) zNWf2t@7U*3aD*IWHv7?(^|JuNas6k&g$069$di~*DMwX2mD7OECCWbo_YfZM0F2i! zmmuT!B3ve)DI17Lg&eLrtRzP`y&UpKJJ!+L4camQ7FY>2Iu-wPO94DxDTvNF-dek) z4)VJ==KG`pi9i5h5SGcFm01Ej?3rg8>aEwpHt!^m>uTtnC>Tw8ol+%pR(i}@yV^6) zG!%gGR-NR#hKHRSHB&+4n3oBc1AWk(sqE!Y^-h+FLTX0&C1xEca{N3TA? zsGFHG#%zk%?6>Qr!VZr4UbWV)2*3!u$bEyc$ksQ$crU%y3yd8d^G$@%Rp)7B-e`Yg zOry1S0e%3fS0x10SFf|`B)`97zNbOKu-2|a7LwWn`)P)2JSg*y2OfDS=mT4G%UF#* z_)#zPd-ZyzULU4<)Jj+CnX`Oe8m!lPf#K3JCI|0fQ7~Ra_9-7@jOnSPkLz>CZPK6Kq+jle%S=PR5vSz}D2MRTyJNkUXqi zi7bWz8^*Q04H@&EVT@_giM2a&>UBcS@>!{FCdwGo8Cl~`qOsQ6Wx7ho6tej6&9|UFPJMAhV+%&~laS zraG)6+^e!jlq~lLk^7#H?C&@d+0GF4h@8Gb*(waL(gJ7e_i7Pr)*~K?XCWg86XCHj za#YTjlyEXk%sm9L5=)C`f<&wi9>OtHY{?@G8EE6`qZ-pLh=<4`U~^=VKkAn>74f?3 z?x5h_gzM~=Q&5nU3YmknQr1$!wrIpFCD>@c2so-rzG<3g1~HN9Y6%F|!>`uwm+JS_ zXIdcsx|6j0{gqFQ=ZfioOqW|^U4QF>f#?Z5ukyxGWorZyrXq0Kiw%%dOGta*V|}^? zAYOYGxHhBGZGgW-Y-wU_l8kchtT3fZkr!F-EfR6eTZSy{){It17&dBL)jSCdMk<3R z38OvVp7REdM*_dBM_fp2`s1eH+nd@Rg_B6($D1H)D?%UPmr00yj%*VP%w}vL{zNd8 z(T$OQ!U7L_xS5>@JJ{FB;m3ryb)HXc*U2EQLR|ba?;+6#bTP7Ebx{&8>%Qayi%;|LA$ zY77Pv+b8BvQE4YdZo+HS03_z?)Cm9e$e#2|w8dPB*k&L5Fyhi1$ey}^5uFSYtROf; z<259fBFPZ$1%jn=u5Va z*=L$U%9m5Eo8ScH$)wzXnYFSuM@9$lQ(V-UpVbkFX{3x?jd-C18)9aX!O1#LWd(qI zMgjXSkZAtzd#Kp7X?og95$)bj6<@g$wR71jy(5ArgV`bZoH{uh-D#0;QoN*#L< zp6)!Kj3<%h1|tHnSxpxdQaxP> zyq_xph*iMODRgRz+^<1_DANj)+14IaviQtvHJ`y@VKKMjmS(uFbnVzj&Ig=149*WN4O_?0dOkWgS(to zAP}FD5S{{Y+BlJx!DH^GfQ_1kfDyToV+n_+(}4pr@c46qU{swXR1i)e9I{%Zvp%}8 z`YI9(y{SfICN_v4^#Za&<`Uw&3*j7*@AMw=k#h{<$uTpMcLlN#R_M0nnx~QZBt5O{ zT;!mvCSZK9a+?GgAA4TLV`mcOtQb~axL3P`WS}KA}5)Bj70bu2z-|?n&}$E ztMXD?>l86hR2mpx2^6=>3y|X;8Xb!*M_SZ#$g0^#nm)GHu8HstK2Xcb2Dns2)~3lFO+`v zc&TQp78zrDB5TVd(HO50T7^V$cnFwatzDSF%OI8BSyLCJh3tVWV(mgpb2bZj47kmT zdu!dORe%vCV@xjulzkDG`W=u-!+_Qx)AvEzh?W)KsUm+ReSmD+dImWoBQdaYS=8#l zs3Z-2-4_97fL{9{mEVL!c4$UG3es96=-51D#Vts4T2tj$(*FTjP^PMe_t6Oe0000< KMNUMnLSTY;=&wQm literal 0 HcmV?d00001 diff --git a/collects/tests/jpr/dessine-arbre.ss b/collects/tests/jpr/dessine-arbre.ss new file mode 100644 index 0000000000..d7ad76f446 --- /dev/null +++ b/collects/tests/jpr/dessine-arbre.ss @@ -0,0 +1,34 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-advanced-reader.ss" "lang")((modname dessine-arbre) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t write mixed-fraction #t #t none #f ()))) +;;; dessine-arbre.ss + +(require "valrose.ss") + +(define (objet->image x) ; x est un operateur ou une feuille + (text (if (number? x) (number->string x) (symbol->string x)) + 18 "black")) + +(define (vert h) (rectangle 1 h 'solid "white")) +(define (horiz w) (rectangle w 1 'solid "white")) + +(define (arbre->image A) ; Arbre --> Image au niveau n + (if (feuille? A) + (objet->image A) + (local [(define ig (arbre->image (fg A))) + (define wg/2 (/ (image-width ig) 2)) + (define id (arbre->image (fd A))) + (define wd/2 (/ (image-width id) 2)) + (define igd (beside/align 'top ig (horiz 20) id)) + (define wgd/2 (/ (image-width igd) 2))] + (above (objet->image (racine A)) + (beside (horiz wg/2) + (line (- wg/2 wgd/2) 20 "black") + (line (- wgd/2 wd/2) 20 "black") + (horiz wd/2)) + (vert 5) + igd)))) + +(arbre->image '(+ (* (+ (* x (- x y)) 2) (* (- a b) longueur)) (/ (* x 2) y))) + + diff --git a/collects/tests/jpr/foo.ss b/collects/tests/jpr/foo.ss new file mode 100644 index 0000000000..ba773def0f --- /dev/null +++ b/collects/tests/jpr/foo.ss @@ -0,0 +1,18 @@ +#lang scheme +(read-accept-reader #t) + +(define (chercher-definition fonc f) + (define (good-def? expr) + (and (pair? expr) + (equal? (car expr) 'define) + (or (equal? (cadr expr) fonc) ; (define fonc ...) + (and (pair? (cadr expr)) (equal? (caadr expr) fonc))))) ; (define (fonc ...) ...) + (call-with-input-file f + (lambda (p-in) + (car (filter good-def? (list-ref (read p-in) 3)))))) ; (module foo scheme (#%module-begin ...)) + +(define (foo x y) ; comment + (+ x y)) + +(printf "The definition of the function foo in this file foo.ss is :\n") +(chercher-definition 'foo "foo.ss") diff --git a/collects/tests/jpr/jeu-du-chaos.ss b/collects/tests/jpr/jeu-du-chaos.ss new file mode 100644 index 0000000000..21ff5262d6 --- /dev/null +++ b/collects/tests/jpr/jeu-du-chaos.ss @@ -0,0 +1,40 @@ +#lang scheme +(require graphics/graphics) + +(open-graphics) +(define VIEW (open-viewport "Essai Graphics" 300 100)) +(define tr-segment (draw-line VIEW)) ; un traceur de segment +(define tr-pixel (draw-pixel VIEW)) ; un traceur de pixel + +(define A (make-posn 150 10)) +(define B (make-posn 10 90)) +(define C (make-posn 290 90)) + +(tr-segment A B "red") +(tr-segment B C "red") +(tr-segment C A "red") + +(define M-INIT (make-posn (random 300) (random 100))) + +(define (jeu-du-chaos) + (define (moyenne x y) + (/ (+ x y) 2)) + (define (milieu A B) + (make-posn (moyenne (posn-x A) (posn-x B)) + (moyenne (posn-y A) (posn-y B)))) + (define (iter nb-fois M) ; M est le dernier point courant affiche + (if (= nb-fois 0) + (void) + (let* ((S (case (random 3) ((0) A) ((1) B) ((2) C))) + (Msuiv (milieu M S))) + (tr-pixel Msuiv "blue") + (iter (- nb-fois 1) Msuiv)))) + (tr-pixel M-INIT "blue") + (iter 4000 M-INIT)) + +(jeu-du-chaos) + + + + + diff --git a/collects/tests/jpr/mon-script.ss b/collects/tests/jpr/mon-script.ss new file mode 100755 index 0000000000..b485c8beaf --- /dev/null +++ b/collects/tests/jpr/mon-script.ss @@ -0,0 +1,30 @@ +#!/usr/bin/env mzscheme +#lang scheme +;;; a Unix script but also a plain Scheme file... + +(define (get-scheme-files) ; la A-liste ((fichier nb-defs) ...) + (map (lambda (f) (list f (nb-defs f))) + (filter (lambda (f) + (and (file-exists? f) (regexp-match ".ss$" f))) + (map path->string (directory-list))))) + +(define (nb-defs f) ; number of definitions in f + (define (is-def? x) ; x is a definition ? + (and (pair? x) (equal? (car x) 'define))) + (call-with-input-file f + (lambda (p-in) + (let ((x (read p-in))) ; is f a module ? + ;(printf "x=~s\n\n" x) + (if (and (pair? x) (equal? (car x) 'module)) ; yes + (length (filter is-def? (list-ref x 3))) ; one only read is enough ! + (do ((e (read p-in) (read p-in)) ; non + (acc (if (is-def? x) 1 0) (if (is-def? e) (+ acc 1) acc))) + ((eof-object? e) acc))))))) + +(read-accept-reader #t) ; for the #lang line +(printf "Current directory is :\n ~a\n" (current-directory)) +(define FILES (get-scheme-files)) +(printf "It contains ~a Scheme files. " (length FILES)) +(printf "Here they are, sorted by the number of definitions :\n") +(printf "~s\n" (sort FILES (lambda (L1 L2) + (<= (second L1) (second L2))))) diff --git a/collects/tests/jpr/monte-carlo.ss b/collects/tests/jpr/monte-carlo.ss new file mode 100644 index 0000000000..3a69e98bef --- /dev/null +++ b/collects/tests/jpr/monte-carlo.ss @@ -0,0 +1,51 @@ +;;; Simulation graphique a la Monte Carlo +;;; ----> Some red points are outside the circle on the bottom right ??? + +#lang scheme/gui + +(define RED-PEN (make-object pen% "red" 2 'solid)) +(define BLACK-PEN (make-object pen% "black" 2 'solid)) +(define BLUE-PEN (make-object pen% "blue" 2 'solid)) +(define YELLOW-BRUSH (make-object brush% "yellow" 'solid)) + +(define FRAME + (new frame% (label "Monte-Carlo") (stretchable-width #f) (stretchable-height #f))) + +(define VPANEL + (new vertical-panel% (parent FRAME))) + +(define TEXT-FIELD + (new text-field% (parent VPANEL) + (label "Nombre de points N =") + (init-value "5000") + (callback (lambda (t e) + (when (eq? (send e get-event-type) 'text-field-enter) + (send CANVAS refresh)))))) + +(define MSG (new message% (parent VPANEL) (label "?") (min-width 50))) + +(define CANVAS + (new canvas% (parent VPANEL) + (min-width 300) (min-height 300) (style '(border)) + (paint-callback + (lambda (obj evt) ; c est le canvas et e est l'evenement + (let ((dc (send obj get-dc))) + (send dc clear) + (send dc set-pen BLUE-PEN) ; le bord du disque + (send dc set-brush YELLOW-BRUSH) ; l'interieur du disque + (send dc draw-ellipse 0 0 299 299) + (let ((s 0) (N (string->number (send TEXT-FIELD get-value)))) + (do ((i 0 (+ i 1))) + ((= i N) (send MSG set-label (number->string (* 4.0 (/ s N))))) + (let ((x (random 300)) (y (random 300))) + (if (< (+ (sqr (- x 150)) (sqr (- y 150))) (sqr 150)) + (begin (send dc set-pen RED-PEN) (set! s (+ s 1))) + (send dc set-pen BLACK-PEN)) + (send dc draw-point x y))))))))) + +(define BUTTON + (new button% (parent VPANEL) (label "Go !") + (callback (lambda (obj evt) + (send CANVAS on-paint))))) + +(send FRAME show #t) diff --git a/collects/tests/jpr/streams.ss b/collects/tests/jpr/streams.ss new file mode 100644 index 0000000000..d9e46a72ca --- /dev/null +++ b/collects/tests/jpr/streams.ss @@ -0,0 +1,52 @@ +#lang scheme + +#| +(define-syntax scons ; SICP ==> ERROR (see Rationale of SRFI-41) + (syntax-rules () + ((scons obj s) (cons obj (delay s))))) + +(define (scar s) (car s)) +(define (scdr s) (force (cdr s))) +|# + +(define-syntax scons + (syntax-rules () + ((scons obj s) (delay (cons obj (delay s)))))) ; from my book + +(define (scar s) (car (force s))) +(define (scdr s) (force (cdr (force s)))) + +; ------------------------------------------------------------------- + +(define (element s k) ; k-th element of s + (if (= k 1) + (scar s) + (element (scdr s) (- k 1)))) + +(define (smerge s1 s2) ; s1 et s2 infinite ascending streams + (let ((x1 (scar s1)) (x2 (scar s2))) + (cond ((< x1 x2) (scons x1 (smerge (scdr s1) s2))) + ((> x1 x2) (scons x2 (smerge s1 (scdr s2)))) + (else (scons x1 (smerge (scdr s1) (scdr s2))))))) + +(define (szoom x S) + (scons (* x (scar S)) (szoom x (scdr S)))) + +(define H (scons 1 (smerge (szoom 2 H) (smerge (szoom 3 H) (szoom 5 H))))) ; Hamming + +(time (element H 20000)) + +;;; SRFI-41 bug + +(define (sfrom n step) + (scons n (sfrom (+ n step) step))) + +(define (smap f s) + (scons (f (scar s)) (smap f (scdr s)))) + +(define (s->list n s) + (if (= n 0) + '() + (cons (scar s) (s->list (- n 1) (scdr s))))) + +(s->list 4 (smap / (sfrom 4 -1))) ; error ou (1/4 1/3 1/2 1) ? diff --git a/collects/tests/jpr/valrose.ss b/collects/tests/jpr/valrose.ss new file mode 100644 index 0000000000..76dfda623f --- /dev/null +++ b/collects/tests/jpr/valrose.ss @@ -0,0 +1,110 @@ +;;; teachpack valrose.ss - jpr, Mars 2010 + +#lang scheme + +(require 2htdp/image 2htdp/universe) ; images et animations, version 2 + +(provide + (all-from-out 2htdp/image 2htdp/universe) + show match ; quelques utilitaires manquants + arbre racine fg fd fdd feuille? operateur? ; les arbres (2-3) d'expressions arithmetiques + pile-vide pile-vide? empiler depiler sommet ; les piles fonctionnelles + atome? make-neg make-fbf2 connecteur arg1 arg2) ; les FBF de la Logique d'ordre 0 + +; petit utilitaire pour avoir les tests dans l'editeur avec echo au toplevel + +(define-syntax show + (syntax-rules () + ((show e) (begin (printf "? ~s\n" 'e) (printf "--> ~s\n" e))))) + +; le type abstrait "arbre 2-3 d'expression algebrique". Toutes les operations sont O(1) + +(define (arbre r Ag . Lfils) ; au moins un fils ! + (cons r (cons Ag Lfils))) + +(define (racine A) + (if (feuille? A) + (error (format "pas de racine pour une feuille : ~a" A)) + (first A))) + +(define (fg A) + (if (feuille? A) + (error (format "pas de fg pour une feuille : ~a" A)) + (second A))) + +(define (fd A) + (if (feuille? A) + (error (format "pas de fd pour une feuille : ~a" A)) + (third A))) + +(define (fdd A) + (if (or (feuille? A) (empty? (rest (rest (rest A))))) + (error (format "le fdd n'existe pas : ~a" A)) + (fourth A))) + +(define (feuille? obj) + (or (number? obj) + (boolean? obj) + (and (symbol? obj) (not (operateur? obj))))) + +(define (operateur? obj) + (if (member obj '(+ * - / < > <= >= =)) #t #f)) + +; le type abstrait "pile fonctionnelle". Toutes les operations sont O(1) + +(define (pile-vide) + empty) + +(define (pile-vide? pile) + (empty? pile)) + +(define (empiler x pile) + (cons x pile)) + +(define (sommet pile) + (if (empty? pile) + (error "Pile vide !") + (first pile))) + +(define (depiler pile) + (if (empty? pile) + (error "Pile vide !") + (rest pile))) + +; le type abstrait "fbf en logique d'ordre 0" +; un parametre F denote une fbf + +(define (atome? F) ; le reconnaisseur d'atomes [symboles p, q, r...] + (symbol? F)) + +(define (make-neg F) ; le constructeur de molecule unaire (negation) + (cond ((atome? F) (list 'non F)) + ((equal? (connecteur F) 'non) (arg1 F)) ; petite simplification au passage... + (else (list 'non F)))) + +(define (make-fbf2 r Fg Fd) ; le constructeur de molecule binaire (et, ou, =>) + (if (not (member r '(et ou =>))) + (error "Mauvais connecteur" r) + (list Fg r Fd))) ; representation interne infixee + +(define (connecteur mol) ; on suppose que mol est une molecule + (if (= (length mol) 2) + (first mol) ; non + (second mol))) ; et, ou, => + +(define (arg1 mol) ; mol est une molecule + (if (= (length mol) 2) + (second mol) + (first mol))) + +(define (arg2 mol) ; mol est une molecule + (if (= (length mol) 2) + (error "Molecule unaire" mol) + (third mol))) + +;(printf "Module valrose : (show expr), (assoc x AL), (sleep n), (current-milliseconds), (gensym symb), +(printf "Module valrose : +(show expr), (match expr clauses ...), +(arbre r Ag Ad), (racine A), (fg A), (fd A), (fdd A), (feuille? A), (operateur? obj), +(pile-vide? P), (pile-vide), (empiler x P), (sommet P), (depiler P), +(atome? F), (make-neg F), (make-fbf2 r Fg Fd), (connecteur mol), (arg1 mol), (arg2 mol)\n") From 06f65546e9dd86fc836f3788e0fb152761255fec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 May 2010 15:32:38 -0600 Subject: [PATCH 50/52] update READMEs for v5.0 Merge to v5.0 --- doc/release-notes/gracket/HISTORY.txt | 6 ++++++ doc/release-notes/racket/HISTORY.txt | 6 ++++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/doc/release-notes/gracket/HISTORY.txt b/doc/release-notes/gracket/HISTORY.txt index d573599420..96d440e962 100644 --- a/doc/release-notes/gracket/HISTORY.txt +++ b/doc/release-notes/gracket/HISTORY.txt @@ -1,3 +1,9 @@ +Version 5.0, May 2010 + +Changed the executable from MrEd to GRacket + +---------------------------------------------------------------------- + Version 4.2.5, March 2010 Changed radio-box% to allow #f as a selection so that no buttons are diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index ae2dfe9e74..8264e3810f 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,5 +1,7 @@ Version 5.0, May 2010 Changed the core executable from mzscheme to racket +Changed paths like the preferences file to use "racket" instead + of "mzscheme" or "plt-scheme" Changed default value printer to use quasiquote style The language of a program's main module can specify run-time configuration actions, such as setting the default printer's @@ -8,9 +10,9 @@ Changed regexp-match* et al. to make ^ matching relative to the original string (not substrings for matches after the for) and to allow empty matches in all positions except immediately after an empty match +Changed regexp-match and other functions to allow a path as + an input Added chaperones -Changed paths like the preferences file to use "racket" instead - of "mzscheme" or "plt-scheme" Version 4.2.5, March 2010 Added scheme/future, enabled by default on main platforms From 91ecad670c49a131c3b87ab4d8217a604e5ca200 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 May 2010 15:35:14 -0600 Subject: [PATCH 51/52] update mailing list address in src/READMEs Merge to v5.0 --- src/README | 2 +- src/worksp/README | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/README b/src/README index 478d72a20a..49492cea17 100644 --- a/src/README +++ b/src/README @@ -13,7 +13,7 @@ Per-platform instructions are below. Please report bugs via one of the following: - DrRacket's "submit bug report" menu (preferred) - http://bugs.racket-lang.org/ - - the mailing list (racket@list.cs.brown.edu) (last resort) + - the mailing list (users@racket-lang.org) (last resort) -PLT racket@racket-lang.org diff --git a/src/worksp/README b/src/worksp/README index 0bd6a4b331..d46055e167 100644 --- a/src/worksp/README +++ b/src/worksp/README @@ -32,7 +32,7 @@ mkbordyn.bat (which requires bcc23.exe, of course). As always, please report bugs via one of the following: - DrRacket's "submit bug report" menu (preferred) - http://bugs.racket-lang.org/ - - the mailing list (racket@list.cs.brown.edu) (last resort) + - the mailing list (users@racket-lang.org) (last resort) -PLT racket@racket-lang.org From bb4b04082addfdf7705167582b7608c8f9f12aa3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 May 2010 16:47:34 -0600 Subject: [PATCH 52/52] fix cmdline-level printf wrapper for Windows It was broken in a way that made gracket-text crash Merge to v5.0 --- src/gracket/gracket.cxx | 9 +++++++-- src/gracket/grmain.cxx | 2 ++ src/racket/cmdline.inc | 6 +++--- src/racket/main.c | 1 + 4 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/gracket/gracket.cxx b/src/gracket/gracket.cxx index ee34eeafbe..6af1e0e4dd 100644 --- a/src/gracket/gracket.cxx +++ b/src/gracket/gracket.cxx @@ -2292,6 +2292,7 @@ static void MrEdSchemeMessages(char *msg, ...) waiting_sema = CreateSemaphore(NULL, 0, 1, NULL); SetConsoleCtrlHandler(ConsoleHandler, TRUE); + { HMODULE hm; gcw_proc gcw; @@ -2336,10 +2337,14 @@ static void MrEdSchemeMessages(char *msg, ...) WriteConsole(console_out, s XFORM_OK_PLUS d, l, &wrote, NULL); } else { + long sz, wrt; char *buffer; DWORD wrote; - buffer = (char *)malloc(5 * strlen(msg)); - vsprintf(buffer, msg, args); + /* FIXME: multiplying by 5 and adding 80 works for + all the cases where printf mode is currently used + for the function, but it's completely a hack. */ + buffer = (char *)malloc((5 * strlen(msg)) + 80); + wrt = vsprintf(buffer, msg, args); WriteConsole(console_out, buffer, strlen(buffer), &wrote, NULL); free(buffer); } diff --git a/src/gracket/grmain.cxx b/src/gracket/grmain.cxx index 18b04acf94..118487e3c0 100644 --- a/src/gracket/grmain.cxx +++ b/src/gracket/grmain.cxx @@ -113,10 +113,12 @@ extern "C" Scheme_Object *scheme_initialize(Scheme_Env *env); #define GET_INIT_FILENAME get_init_filename #if REDIRECT_STDIO || WINDOW_STDIO || WCONSOLE_STDIO # define PRINTF mred_console_printf +# define CMDLINE_FFLUSH(x) /* nothing */ static void (*mred_console_printf)(char *str, ...); # define NEED_MRED_CONSOLE_PRINTF #else # define PRINTF printf +# define CMDLINE_FFLUSH fflush #endif #define PROGRAM "GRacket" #define PROGRAM_LC "gracket" diff --git a/src/racket/cmdline.inc b/src/racket/cmdline.inc index a98869abab..1bc3f94272 100644 --- a/src/racket/cmdline.inc +++ b/src/racket/cmdline.inc @@ -1078,7 +1078,7 @@ static int run_from_cmd_line(int argc, char *_argv[], #endif #if defined(USE_FD_PORTS) || defined(WINDOWS_FILE_HANDLES) - fflush(stdout); + CMDLINE_FFLUSH(stdout); #endif } #endif /* DONT_PARSE_COMMAND_LINE */ @@ -1286,7 +1286,7 @@ static int run_from_cmd_line(int argc, char *_argv[], ); PRINTF(prog, BANNER); #if defined(WINDOWS_FILE_HANDLES) - fflush(stdout); + CMDLINE_FFLUSH(stdout); #endif return 0; bad_switch: @@ -1298,7 +1298,7 @@ static int run_from_cmd_line(int argc, char *_argv[], show_need_help: PRINTF("Use the --help or -h flag for help.\n"); #if defined(DETECT_WIN32_CONSOLE_STDIN) - fflush(stdout); + CMDLINE_FFLUSH(stdout); #endif return 1; #endif diff --git a/src/racket/main.c b/src/racket/main.c index a5300a1174..cdf056e6ad 100644 --- a/src/racket/main.c +++ b/src/racket/main.c @@ -146,6 +146,7 @@ extern Scheme_Object *scheme_initialize(Scheme_Env *env); #endif #define GET_INIT_FILENAME get_init_filename #define PRINTF printf +#define CMDLINE_FFLUSH fflush #define PROGRAM "Racket" #define PROGRAM_LC "racket" #define INITIAL_BIN_TYPE "zi"