From f1d258f20b6eb70e7e54f938e3bb3e2d5365cf11 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 24 May 2010 09:50:57 -0400 Subject: [PATCH 01/31] fixed 10923 --- collects/teachpack/2htdp/scribblings/universe.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index e94a652c8e..f5837cfd61 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -162,7 +162,7 @@ The design of a world program demands that you come up with a data (on-tick tick-expr rate-expr) (on-key key-expr) (on-release release-expr) - (on-mouse key-expr) + (on-mouse mouse-expr) (to-draw draw-expr) (to-draw draw-expr width-expr height-expr) (stop-when stop-expr) (stop-when stop-expr last-scene-expr) @@ -371,7 +371,7 @@ All @tech{MouseEvent}s are represented via strings: @defproc[(mouse=? [x mouse-event?][y mouse-event?]) boolean?]{ compares two @tech{MouseEvent}s for equality} -@defform[(on-mouse clack-expr) +@defform[(on-mouse mouse-expr) #:contracts ([clack-expr (-> (unsyntax @tech{WorldState}) @@ -694,7 +694,7 @@ As mentioned, all event handlers may return @tech{WorldState}s or } @defform/none[#:literals (on-mouse) - (on-mouse clack-expr) + (on-mouse mouse-expr) #:contracts ([clack-expr (-> (unsyntax @tech{WorldState}) From f243a0e6176de32df1619ddbd9f08560ec9e240e Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 24 May 2010 10:03:59 -0400 Subject: [PATCH 02/31] fixed 10922 --- collects/teachpack/2htdp/scribblings/universe.scrbl | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index f5837cfd61..02a3fc3326 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -375,13 +375,18 @@ All @tech{MouseEvent}s are represented via strings: #:contracts ([clack-expr (-> (unsyntax @tech{WorldState}) - natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) + integer? integer? (unsyntax @tech{MouseEvent}) (unsyntax @tech{WorldState}))])]{ tell DrRacket to call @scheme[clack-expr] on the current world, the current @scheme[x] and @scheme[y] coordinates of the mouse, and and a @tech{MouseEvent} for every (noticeable) action of the mouse by the computer user. The result of the call becomes the current world. + For @scheme["leave"] and @scheme["enter"] events, the coordinates of the + mouse click may be outside of the (implicitly) rectangle. That is, the + coordinates may be negative or larger than the (implicitly) specified + width and height. + Note: the computer's software doesn't really notice every single movement of the mouse (across the mouse pad). Instead it samples the movements and signals most of them.} @@ -698,7 +703,7 @@ As mentioned, all event handlers may return @tech{WorldState}s or #:contracts ([clack-expr (-> (unsyntax @tech{WorldState}) - natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) + integer? integer? (unsyntax @tech{MouseEvent}) (or/c (unsyntax @tech{WorldState}) package?))])]{ } From fe67f369fa11f22bbbb5c1f199bfe5e40ab509cd Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 24 May 2010 10:09:01 -0400 Subject: [PATCH 03/31] prep for debugging --- collects/2htdp/private/utilities.rkt | 11 +++++++++++ collects/2htdp/private/world.rkt | 1 + 2 files changed, 12 insertions(+) create mode 100644 collects/2htdp/private/utilities.rkt diff --git a/collects/2htdp/private/utilities.rkt b/collects/2htdp/private/utilities.rkt new file mode 100644 index 0000000000..f9b76f3ee0 --- /dev/null +++ b/collects/2htdp/private/utilities.rkt @@ -0,0 +1,11 @@ +#lang racket + +(provide/contract + ;; like the unix debugging facility + [tee (-> symbol? any/c any)] + ) + + +(define (tee tag x) + (printf "~a ~s\n" tag x) + x) \ No newline at end of file diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index 7c2b768e33..6cad3ac65f 100644 --- a/collects/2htdp/private/world.rkt +++ b/collects/2htdp/private/world.rkt @@ -6,6 +6,7 @@ "checked-cell.ss" "stop.ss" "universe-image.ss" + "utilities.rkt" htdp/error mzlib/runtime-path mrlib/bitmap-label From cc162f3eeb8d66e20cdc4255cb13a9626987fc9e Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Mon, 24 May 2010 09:17:10 -0500 Subject: [PATCH 04/31] Brings the Redex examples documentation up to date (for 5.0 release) --- collects/redex/doc.txt | 1456 ----------------- collects/redex/examples/README | 52 + collects/redex/examples/r6rs/README | 8 +- .../redex/examples/r6rs/show-examples.rkt | 5 - 4 files changed, 56 insertions(+), 1465 deletions(-) delete mode 100644 collects/redex/doc.txt create mode 100644 collects/redex/examples/README diff --git a/collects/redex/doc.txt b/collects/redex/doc.txt deleted file mode 100644 index 06a5f4f6d4..0000000000 --- a/collects/redex/doc.txt +++ /dev/null @@ -1,1456 +0,0 @@ -_PLT Redex: Reduction Semantics_ -_PLT Redex: Operational Semantics_ - -This collection provides these files: - - _reduction-semantics.ss_: the core reduction semantics - library - - _gui.ss_: a _visualization tool for reduction sequences_. - - _pict.ss_: a library for _generating picts and postscript from semantics_ - -In addition, the examples subcollection contains several -small languages to demonstrate various different uses of -this tool: - - _arithmetic.ss_: an arithmetic language with every - possible order of evaluation - - _beginner.ss_: a PLT redex implementation of (much of) the - beginning student teaching language. - - _church.ss_: church numerals with call by name - normal order evaluation - - _combinators.ss_: fills in the gaps in a proof in - Barendregt that i and j (defined in the file) are - a combinator basis - - _compatible-closure.ss_: an example use of compatible - closure. Also, one of the first examples from Matthias - Felleisen and Matthew Flatt's monograph - - _eta.ss_: shows how eta is, in general, unsound. - - _ho-contracts.ss_: computes the mechanical portions of a - proof in the Contracts for Higher Order Functions paper - (ICFP 2002). Contains a sophisticated example use of an - alternative pretty printer. - - iswim.ss : see further below. - - _macro.ss_: models macro expansion as a reduction semantics. - - _letrec.ss_: shows how to model letrec with a store and - some infinite looping terms - - _omega.ss_: the call by value lambda calculus with call/cc. - Includes omega and two call/cc-based infinite loops, one of - which has an ever-expanding term size and one of which has - a bounded term size. - - _semaphores.ss_: a simple threaded language with semaphores - - _subject-reduction.ss_: demos traces/pred that type checks - the term. - - _threads.ss_: shows how non-deterministic choice can be - modeled in a reduction semantics. Contains an example use - of a simple alternative pretty printer. - - _types.ss_: shows how the simply-typed lambda calculus's - type system can be written as a rewritten system (see - Kuan, MacQueen, Findler in ESOP 2007 for more). - -====================================================================== - -The _reduction-semantics.ss_ library defines a pattern -language, used in various ways: - - pattern = any - | number - | string - | variable - | (variable-except ...) - | (variable-prefix ) - | variable-not-otherwise-mentioned - | hole - | (hole ) - | - | (name ) - | (in-hole ) - | (in-named-hole ) - | (hide-hole ) - | (side-condition ) - | (cross ) - | ( ...) - | - - pattern-sequence = pattern - | ... ;; literal ellipsis - | ..._ - -The patterns match sexpressions. The _any_ pattern matches -any sepxression. The _number_ pattern matches any -number. The _string_ pattern matches any string. Those three -patterns may also be suffixed with an underscore and another -identifier, in which case they bind the full name (as if it -were an implicit `name' pattern) and match the portion -before the underscore. - -The _variable_ pattern matches any symbol. The -_variable-except_ pattern matches any variable except those -listed in its argument. This is useful for ensuring that -keywords in the language are not accidentally captured by -variables. The _variable-prefix_ pattern matches any symbol -that begins with the given prefix. The -_variable-not-otherwise-mentioned_ pattern matches any -symbol except those that are used as literals elsewhere in -the language. - -The _hole_ pattern matches anything when inside a matching -in-hole pattern. The (hole ) variation on -that pattern is used in conjunction with in-named-hole to -support languages that require multiple patterns in a -hole. If the hole pattern is not being matched as part of -matching an in-hole pattern, it only matches the hole -(extracted as the result of some earlier match of the -in-hole pattern). - -NOTE: If you wish to make a two element list whose elements - are both holes, you must write this: - - ((hole #f) hole) - - If you were to write this: (hole hole), that would be - interpreted as a single hole whose name is "hole". - -The __ pattern stands for a literal symbol that must -match exactly, unless it is the name of a non-terminal in a -relevant language or contains an underscore. - -If it is a non-terminal, it matches any of the right-hand -sides of that non-terminal. - -If the symbol is a non-terminal followed by an underscore, -for example e_1, it is implicitly the same as a name pattern -that matches only the non-terminal, (name e_1 e) for the -example. Accordingly, repeated uses of the same name are -constrainted to match the same expression. - -If the symbol is a non-terminal followed by _!_, for example -e_!_1, it is also treated as a pattern, but repeated uses of -the same pattern are constrained to be different. For -example, this pattern: - - (e_!_1 e_!_1 e_!_1) - -matches lists of three "e"s, but where all three of them are -distinct. - -Unlike the _ patterns, the _!_ patterns do not bind names. - -If _ names and _!_ are mixed, they are treated as -separate. That is, this pattern (e_1 e_!_1) matches just the -same things as (e e), but the second doesn't bind any -variables. - -If the symbol otherwise has an underscore, it is an error. - -_name_: The pattern: - - (name ) - -matches and binds using it to the name . - -_in-hole_: The (in-hole ) matches the first -pattern. This match must include exactly one match against the second -pattern. If there are zero or more than one match, an -exception is raised. - -When matching the first argument of in-hole, the `hole' pattern -matches any sexpression. Then, the sexpression that matched the hole -pattern is used to match against the second pattern. - -_in-named-hole_: The pattern: - - (in-named-hole ) - -is similar in spirit to in-hole, except that it supports -languages with multiple holes in a context. The first -argument identifies which hole, using the (hole ) -pattern that this expression requires and the rest of the -arguments are just like in-hole. That is, if there are -multiple holes in a term, each matching a different (hole -) pattern, this one selects only the holes that are -named by the first argument to in-named-hole. - -_hide-hole_: The (hide-hole pattern) pattern matches what -the embedded pattern matches but if the pattern matcher is -looking for a decomposition, it ignores any holes found in -that pattern. - -_side-condition_: The (side-condition pattern guard) pattern matches -what the embedded pattern matches, and then the guard expression is -evaluated. If it returns #f, the pattern fails to match, and if it -returns anything else, the pattern matches. In addition, any -occurrences of `name' in the pattern are bound using `term-let' -(see below) in the guard. - -_cross_: The (cross ) pattern is used for the compatible -closure functions. If the language contains a non-terminal with the -same name as , the pattern (cross ) matches the -context that corresponds to the compatible closure of that -non-terminal. - -The (pattern-sequence ...) pattern matches a sexpression -list, where each pattern-sequence element matches an element -of the list. In addition, if a list pattern contains an -ellipsis, the ellipsis is not treated as a literal, instead -it matches any number of duplications of the pattern that -came before the ellipses (including 0). Furthermore, each -(name ) in the duplicated pattern binds a -list of matches to , instead of a single match. (A -nested duplicated pattern creates a list of list matches, -etc.) Ellipses may be placed anywhere inside the row of -patterns, except in the first position or immediately after -another ellipses. - -Multiple ellipses are allowed. For example, this pattern: - - ((name x a) ... (name y a) ...) - -matches this sexpression: - - (a a) - -three different ways. One where the first a in the pattern -matches nothing, and the second matches both of the -occurrences of `a', one where each named pattern matches a -single `a' and one where the first matches both and the -second matches nothing. - -If the ellipses is named (ie, has an underscore and a name -following it, like a variable may), the pattern matcher -records the length of the list and ensures that any other -occurrences of the same named ellipses must have the same -length. - -As an example, this pattern: - - ((name x a) ..._1 (name y a) ..._1) - -only matches this sexpression: - - (a a) - -one way, with each named pattern matching a single a. Unlike -the above, the two patterns with mismatched lengths is ruled -out, due to the underscores following the ellipses. - -Also, like underscore patterns above, if an underscore -pattern begins with ..._!_, then the lengths must be -different. - -Thus, with the pattern: - - ((name x a) ..._!_1 (name y a) ..._!_1) - -and the expression - - (a a) - -two matches occur, one where x is bound to '() and y is -bound to '(a a) and one where x is bound to '(a a) and y is -bound to '(). - -> (define-language (non-terminal-spec pattern ...) ...) SYNTAX - non-terminal-spec = symbol - | (symbol ...) - -This form defines the grammar of a language. It allows the -definition of recursive patterns, much like a BNF, but for -regular-tree grammars. It goes beyond their expressive -power, however, because repeated `name' patterns and -side-conditions can restrict matches in a context-sensitive -way. - -The non-terminal-spec can either by a symbol, indicating a -single name for this non-terminal, or a sequence of symbols, -indicating that all of the symbols refer to these -productions. - -As a simple example of a grammar, this is the lambda -calculus: - - (define-language lc-lang - (e (e e ...) - x - v) - (c (v ... c e ...) - hole) - (v (lambda (x ...) e)) - (x variable-not-otherwise-mentioned)) - -with non-terminals e for the expression language, x for -variables, c for the evaluation contexts and v for values. - -> (define-extended-language (non-terminal pattern ...) ...) - -This form extends a language with some new, replaced, or -extended non-terminals. For example, this language: - - (define-extended-language lc-num-lang - lc-lang - (e .... ;;; extend the previous `e' non-terminal - + - number) - (v .... - + - number) - (x (variable-except lambda +))) - -extends lc-lang with two new alternatives for both the `e' -and `v' nonterminal, replaces the `x' non-terminal with a -new one, and carries the `c' non-terminal forward. - -The four-period ellipses indicates that the new language's -non-terminal has all of the alternatives from the original -language's non-terminal, as well as any new ones. If a -non-terminal occurs in both the base language and the -extension, the extension's non-terminal replaces the -originals. If a non-terminal only occurs in either the base -language, then it is carried forward into the -extension. And, of course, extend-language lets you add new -non-terminals to the language. - -If a language is has a group of multiple non-terminals -defined together, extending any one of those non-terminals -extends all of them. - -> language-nts :: (compiled-lang? . -> . (listof symbol?)) - -Returns the list of non-terminals (as symbols) that are -defined by this language. - -> compiled-lang? :: (any? . -> . boolean?) - -Returns #t if its argument was produced by `language', #f -otherwise. - -> (term-let ([tl-pat expr] ...) body) SYNTAX - -Matches each given id pattern to the value yielded by -evaluating the corresponding expr and binds each variable in -the id pattern to the appropriate value (described -below). These bindings are then accessible to the `term' -syntactic form. - -Identifier-patterns are terms in the following grammar: - - tl-pat ::= identifier - | (tl-pat-ele ...) -tl-pat-ele ::= tl-pat - | tl-pat ellipses - -where ellipses is the literal symbol consisting of three -dots (and the ... indicates repetition as usual). If tl-pat -is an identifier, it matches any value and binds it to the -identifier, for use inside `term'. If it is a list, it -matches only if the value being matched is a list value and -only if every subpattern recursively matches the -corresponding list element. There may be a single ellipsis -in any list pattern; if one is present, the pattern before -the ellipses may match multiple adjacent elements in the -list value (possibly none). - -> (term s-expr) SYNTAX - -This form is used for construction of new s-expressions in -the right-hand sides of reductions. It behaves similarly to -quasiquote except for a few special forms that are -recognized (listed below) and that names bound by `term-let' are -implicitly substituted with the values that those names were -bound to, expanding ellipses as in-place sublists (in the -same manner as syntax-case patterns). - -For example, - -(term-let ([body '(+ x 1)] - [(expr ...) '(+ - (values * /))] - [((id ...) ...) '((a) (b) (c d))]) - (term (let-values ([(id ...) expr] ...) body))) - -evaluates to - -'(let-values ([(a) +] - [(b) -] - [(c d) (values * /)]) - (+ x 1)) - -It is an error for a term variable to appear in an -expression with an ellipsis-depth different from the depth -with which it was bound by `term-let'. It is also an error -for two `term-let'-bound identifiers bound to lists of -different lengths to appear together inside an ellipsis. - -The special forms recognized by term are: - - (in-hole a b) - - This is the dual to the pattern `in-hole' -- it accepts - a context and an expression and uses `plug' to combine - them. - - (in-named-hole name a b) - - Like in-hole, but substitutes into a hole with a particular name. - - hole - - This produces a hole. - - (hole name) - - This produces a hole with the name `name'. To produce an unnamed - hole, use #f as the name. - -> (term-match [ (term-match/single [ (reduction-relation ...) SYNTAX - - = (--> ...) - = - - | (fresh ...) - | (side-condition ...) - | (where e) - = - var - | ((var1 ...) (var2 ...)) - -Defines a reduction relation casewise, one case for each of -the clauses beginning with -->. Each of the s -refers to the , and binds variables in the -. The behave like the argument to `term'. - -Following the lhs & rhs specs can be the name of the -reduction rule, declarations of some fresh variables, and/or -some side-conditions. The can either be a literal -name (identifier), or a literal string. - -The fresh variables clause generates variables that do not -occur in the term being matched. If the is a -variable, that variable is used both as a binding in the -rhs-exp and as the prefix for the freshly generated -variable. - -The second case of a is used when you want to -generate a sequence of variables. In that case, the ellipses -are literal ellipses; that is, you must actually write -ellipses in your rule. The variable var1 is like the -variable in first case of a , namely it is -used to determine the prefix of the generated variables and -it is bound in the right-hand side of the reduction rule, -but unlike the single-variable fresh clause, it is bound to -a sequence of variables. The variable var2 is used to -determine the number of variables generated and var2 must be -bound by the left-hand side of the rule. - -The side-conditions are expected to all hold, and have the -format of the second argument to the side-condition pattern, -described above. - -Each where clauses binds a variable and the side-conditions -(and where clauses) that follow the where declaration are in -scope of the where declaration. The bindings are the same as -bindings in a term-let expression. - -As an example, this - - (reduction-relation - lc-lang - (--> (in-hole c_1 ((lambda (variable_i ...) e_body) v_i ...)) - (in-hole c_1 ,(foldl lc-subst - (term e_body) - (term (v_i ...)) - (term (variable_i ...)))) - beta-v)) - -defines a reduction relation for the lambda-calculus above. - -> (reduction-relation - - ( ) ... - with - [( ) - ( )] ...) - -Defines a reduction relation with shortcuts. As above, the -first section defines clauses of the reduction relation, but -instead of using -->, those clauses can use any identifier -for an arrow, as long as the identifier is bound after the -`with' clause. - -Each of the clauses after the `with' define new relations -in terms of other definitions after the `with' clause or in -terms of the main --> relation. - -[ NOTE: `fresh' is always fresh with respect to the entire - term, not just with respect to the part that matches the - right-hand-side of the newly defined arrow. ] - -For example, this - - (reduction-relation - lc-num-lang - (==> ((lambda (variable_i ...) e_body) v_i ...) - ,(foldl lc-subst - (term e_body) - (term (v_i ...)) - (term (variable_i ...)))) - (==> (+ number_1 ...) - ,(apply + (term (number_1 ...)))) - - with - [(--> (in-hole c_1 a) (in-hole c_1 b)) - (==> a b)]) - -defines reductions for the lambda calculus with numbers, -where the ==> relation is defined by reducing in the context -c. - -> (extend-reduction-relation ...) - -This form extends the reduction relation in its first -argument with the rules specified in . They should -have the same shape as the rules (including the `with' -clause) in an ordinary reduction-relation. - -If the original reduction-relation has a rule with the same -name as one of the rules specified in the extension, the old -rule is removed. - -In addition to adding the rules specified to the existing -relation, this form also reinterprets the rules in the -original reduction, using the new language. - -> union-reduction-relations :: (reduction-relation? ... -> reduction-relation?) - -Combines all of the argument reduction relations into a -single reduction relation that steps when any of the -arguments would have stepped. - -> reduction-relation->rule-names :: - (reduction-relation? . -> . (listof (union false/c symbol?))) - -Returns the names of all of the reduction relation's clauses -(or false if there is no name for a given clause). - -> (compatible-closure ) SYNTAX - -This accepts a reduction, a language, the name of a -non-terminal in the language and returns the compatible -closure of the reduction for the specified non-terminal. - -> (context-closure ) SYNTAX - -This accepts a reduction, a language, a pattern representing -a context (ie, that can be used as the first argument to -`in-hole'; often just a non-terminal) in the language and -returns the closure of the reduction in that context. - -> (define-metafunction name - [ (side-condition ) ...] ...) SYNTAX - -The `define-metafunction' form builds a function on -sexpressions according to the pattern and right-hand-side -expressions. The first argument indicates the language used -to resolve non-terminals in the pattern expressions. Each of -the rhs-expressions is implicitly wrapped in `term'. In -addition, recursive calls in the right-hand side of the -metafunction clauses should appear inside `term'. - -If specified, the side-conditions are collected with an -`and' and used as guards on the case being matched. The -argument to each side-condition should be a Scheme -expression, and the pattern variables in the are -bound in that expression. - -As an example, this metafunction finds the free variables in -an expression in the lc-lang above: - - ;; free-vars : e -> (listof x) - (define-metafunction free-vars - lc-lang - [(e_1 e_2 ...) - ,(apply append (term ((free-vars e_1) (free-vars e_2) ...)))] - [x_1 ,(list (term x_1))] - [(lambda (x_1 ...) e_1) - ,(foldr remq (term (free-vars e_1)) (term (x_1 ...)))]) - -The first argument to define-metafunction is the grammar -(defined above). Following that are three cases, one for -each variation of expressions (e in lc-lang). The right-hand -side of each clause begins with a comma, since they are -implicitly wrapped in `term'. The free variables of an -application are the free variables of each of the subterms; -the free variables of a variable is just the variable -itself, and the free variables of a lambda expression are -the free variables of the body, minus the bound parameters. - -> (define-metafunction/extension name extending-name - [ (side-condition ) ...] ...) SYNTAX - -This defines a metafunction as an extension of an existing -one. The extended metafunction behaves as if the original -patterns were in this definitions, with the name of the -function fixed up so that recursive functions behave as expected. - -> (define-multi-args-metafunction name - [ (side-condition ) ...] ...) SYNTAX - -Like define-metafunction, this defines a -metafunction. Unlike it, this defines a metafunction that -accepts multiple arguments. - -There are two significant differences: - - - patterns match the entire argument list, rather than just - matching the single argument - - the typesetting for define-multi-args-metafunction uses - commas to separate the arguments in the definition - and at the callsites. - -> (define-multi-arg-metafunction/extension name extending-name - [ (side-condition ) ...] ...) SYNTAX - -Like define-metafunction/extension, this defines a -metafunction as an extension of an existing one, but this -time for multi-argument metafunctions. - -> (in-domain? ) - -Returns #t if is in the domain of the specified -metafunction. - -If the metafunction is defined with define-metafunction, -then the term representing the argument should appear -exactly as it appears in a call to the metafunction. - -If the metafunction is defined with -define-multi-args-metafunction, then the arguments should -be parenthesized. - -> (test-equal e1 e2) SYNTAX - -Tests to see if e1 is equal to e2. - -> (test--> reduction-relation e1 e2 ...) SYNTAX - -Tests to see if the value of e1 (which should be a term), -reduces to the e2s. - -> (test-predicate p? e) SYNTAX - -Tests to see if the value of `e' matches the predicate p?. - -> test-results :: (-> void?) - -Prints out how many tests passed and failed, and resets the -counters so that next time this function is called, it -prints the test results for the next round of tests. - -> plug :: (any? any? . -> . any) - -The first argument to this function is an sexpression to -plug into. The second argument is the sexpression to replace -in the first argument. It returns the replaced term. This is -also used when a `term' sub-expression contains `in-hole'. - -> apply-reduction-relation :: (reduction-relation? any? . -> . (listof any?)) - -Reduce accepts a list of reductions, a term, and returns a -list of terms that the term reduces to. - -> apply-reduction-relation/tag-with-names :: - (-> reduction-relation? - any/c - (listof (list/c (union false/c string?) any/c))) - -Like apply-reduction-relation, but the result indicates the -names of the reductions that were used. - -> apply-reduction-relation* :: - (reduction-relation? any? . -> . (listof (listof any?)) - -apply-reduction-relation* accepts a list of reductions and a -term. It returns the results of following every reduction -path from the term. If there are infinite reduction -sequences starting at the term, this function will not -terminate. - -> (redex-match lang pattern any) SYNTAX - -Matches the pattern (in the language) against the third -expression. If it matches, this returns a list of match -structures describing the matches. If it fails, it returns -#f. - -> (redex-match lang pattern) SYNTAX - -Builds a procedure for efficiently testing if expressions -match the pattern `pattern' in the language `lang'. The -procedures accepts a single expression and if the expresion -matches, it returns a list of match structures describing the -matches. If the match fails, the procedure returns #f. - -> match? :: (any/c . -> . boolean?) - -Determines if a value is a mtch structure. - -> match-bindings :: (mtch? -> (listof bind?)) - -This returns a bindings structure (see below) that -binds the pattern variables in this match. - -> variable-not-in :: (any? symbol? . -> . symbol?) - -This helper function accepts an sexpression and a -variable. It returns a variable not in the sexpression with -a prefix the same as the second argument. - -> variables-not-in :: (any? (listof symbol?) . -> . (listof symbol?)) - -This function, like variable-not-in, makes variables that do -no occur in its first argument, but it returns a list of -such variables, one for each variable in its second -argument. - -Does not expect the input symbols to be distinct, but does -produce variables that are always distinct. - -> make-bind :: (symbol? any? . -> . bind?) -> bind? :: (any? . -> . boolean?) -> bind-name :: (bind? . -> . symbol?) -> bind-exp :: (bind? . -> . any?) - -Constructor, predicate, and selector functions for the rib -values contained within a bindings (returned by redex-match). -Each rib associates a name with an s-expression from the -language, or a list of such s-expressions, if the (name ...) -clause is followed by an ellipsis. Nested ellipses produce -nested lists. - -> set-cache-size! :: (union #f positive-integer) -> void - -Changes the cache size; a #f disables the cache -entirely. The default size is 350. - -The cache is per-pattern (ie, each pattern has a cache of -size at most 350 (by default)) and is a simple table that -maps expressions to how they matched the pattern. When the -cache gets full, it is thrown away and a new cache is -started. - -_Debugging PLT Redex Programs_ - -It is easy to write grammars and reduction rules that are -subtly wrong and typically such mistakes result in examples -that just get stuck when viewed in a `traces' window. - -The best way to debug such programs is to find an expression -that looks like it should reduce but doesn't and try to find -out what pattern is failing to match. To do so, use the -redex-match special form, described above. - -In particular, first ceck to see if the term matches the -main non-terminal for your system (typically the expression -or program nonterminal). If it does not, try to narrow down -the expression to find which part of the term is failing to -match and this will hopefully help you find the problem. If -it does match, figure out which reduction rule should have -matched, presumably by inspecting the term. Once you have -that, extract a pattern from the left-hand side of the -reduction rule and do the same procedure until you find a -small example that shoudl work but doesn't (but this time -you might also try simplifying the pattern as well as -simplifying the expression). - - -====================================================================== - -The _gui.ss_ library provides the following functions: - -> (stepper reductions expr [pp]) :: - (opt-> (compiled-lang? - reduction-relation? - any/c) - ((or/c (any -> string) - (any output-port number (is-a?/c text%) -> void))) - void?) - -This function opens a stepper window for exploring the -behavior of its third argument in the reduction system -described by its first two arguments. - -The pp function is used to specially print expressions. It -must either accept one or four arguments. If it accepts one -argument, it will be passed each term and is expected to -return a string to display the term. - -If the pp function takes four arguments, it should render -its first argument into the port (its second argument) with -width at most given by the number (its third argument). The -final argument is the text where the port is connected -- -characters written to the port go to the end of the editor. - -The default pp, provided as default-pretty-printer, uses -MzLib's pretty-print function. See threads.ss in the -examples directory for an example use of the one-argument -form of this argument and ho-contracts.ss in the examples -directory for an example use of its four-argument form. - -> (stepper/seed reductions seed [pp]) :: - (opt-> (compiled-lang? - reduction-relation? - (cons/c any/c (listof any/c))) - ((or/c (any -> string) - (any output-port number (is-a?/c text%) -> void))) - void?) - -Like `stepper', this function opens a stepper window, but it -seeds it with the reduction-sequence supplied in `terms'. - -> (traces reductions expr - #:pred [pred (lambda (x) #t)] - #:pp [pp default-pretty-printer] - #:colors [colors '()] - #:multiple? [multiple? #f]) - lang : language - reductions : (listof reduction) - expr : (or/c (listof sexp) sexp) - multiple : boolean --- controls interpretation of expr - pred : (or/c (sexp -> any) - (sexp term-node? any)) - pp : (or/c (any -> string) - (any output-port number (is-a?/c text%) -> void)) - colors : (listof (list string string)) - -This function opens a new window and inserts each expression -in expr (if multiple is #t -- if multiple is #f, then expr -is treated as a single expression). Then, it reduces the -terms until either reduction-steps-cutoff (see below) -different terms are found, or no more reductions can -occur. It inserts each new term into the gui. Clicking the -`reduce' button reduces until reduction-steps-cutoff more -terms are found. - -The pred function indicates if a term has a particular -property. If it returns #f, the term is displayed with a -pink background. If it returns a string or a color% object, -the term is displayed with a background of that color (using -the-color-database<%> to map the string to a color). If it -returns any other value, the term is displayed normally. If -the pred function accepts two arguments, a term-node -corresponding to the term is passed to the predicate. This -lets the predicate function explore the (names of the) -reductions that led to this term, using term-node-children, -term-node-parents, and term-node-labels. - -The pred function may be called more than once per node. In -particular, it is called each time an edge is added to a -node. The latest value returned determines the color. - -The pp argument is the same as to the stepper functions -(above). - -The colors argument, if provided, specifies a list of -reduction-name/color-string pairs. The traces gui will color -arrows drawn because of the given reduction name with the -given color instead of using the default color. - -You can save the contents of the window as a postscript file -from the menus. - -> term-node-children :: (-> term-node (listof term-node)) - -Returns a list of the children (ie, terms that this term -reduces to) of the given node. - -Note that this function does not return all terms that this -term reduces to -- only those that are currently in the -graph. - -> term-node-parents :: (-> term-node (listof term-node)) - -Returns a list of the parents (ie, terms that reduced to the -current term) of the given node. - -Note that this function does not return all terms that -reduce to this one -- only those that are currently in the -graph. - -> term-node-labels :: (-> term-node (listof (union false/c string))) - -Returns a list of the names of the reductions that led to -the given node, in the same order as the result of -term-node-parents. If the list contains #f, that means that -the corresponding step does not have a label. - -> term-node-set-color! :: - (-> term-node? - (or/c string? (is-a?/c color%) false/c) - void?) - -Changes the highlighting of the node; if its second argument -is #f, the coloring is removed, otherwise the color is set -to the specified color% object or the color named by the -string. The color-database<%> is used to convert the string -to a color% object. - -> term-node-set-red! :: (-> term-node boolean void?) - -Changes the highlighting of the node; if its second argument -is #t, the term is colored pink, if it is #f, the term is -not colored specially. - -> term-node-expr :: (-> term-node any) - -Returns the expression in this node. - -> term-node? :: (-> any boolean) - -Recognizes term nodes. - -> (reduction-steps-cutoff) -> (reduction-steps-cutoff number) - -A parameter that controls how many steps the `traces' function -takes before stopping. - -> (initial-font-size) -> (initial-font-size number) - -A parameter that controls the initial font size for the terms shown -in the GUI window. - -> (initial-char-width) -> (initial-char-width number) - -A parameter that determines the initial width of the boxes -where terms are displayed (measured in characters) for both -the stepper and traces. - -> (dark-pen-color color-or-string) -> (dark-pen-color) => color-or-string - -> (dark-brush-color color-or-string) -> (dark-brush-color) => color-or-string - -> (light-pen-color color-or-string) -> (light-pen-color) => color-or-string - -> (light-brush-color color-or-string) -> (light-brush-color) => color-or-string - -These four parameters control the color of the edges in the graph. - -====================================================================== - -The _pict.ss_ library provides functions designed to -automatically typeset grammars, reduction relations, and -metafunction written with plt redex. - -Each grammar, reduction relation, and metafunction can be -saved in a .ps file (as encapsulated postscript), or can be -turned into a pict. - -Picts are more useful for debugging since DrRacket REPL will -show you the pict directly (albeit with slightly different -fonts than you'd see in the .ps file). You can also use the -picts with Slideshow's pict library to build more complex -arrangements of the figures and add other picts. See -Slideshow for details. - -If you are only using the picts to experiment in DrRacket's -REPL, be sure your program is in the GUI library, and -contains this header: - - #lang scheme/gui - (require texpict/mrpict) - (dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))) - -Be sure to remove the call to dc-for-text-size before you -generate .ps files, otherwise the font spacing will be wrong -in the .ps file. - -> language->pict :: - (->* (compiled-lang? - (or/c false/c (cons/c symbol? (listof symbol?)))) - ((or/c false/c (cons/c symbol? (listof symbol?)))) - pict?) - -> language->ps :: - (->* (compiled-lang? - (or/c path? string?)) - ((or/c false/c (cons/c symbol? (listof symbol?)))) - void?) - -These two functions turn a languages into picts. The first -argument is the language, and the second is a list of -non-terminals that should appear in the pict. It may only -contain symbols that are in the language's set of -non-terminals. - -For language->ps, the path argument is a filename for the -PostScript file. - -> extend-language-show-union : (parameter/c boolean?) - -If this is #t, then a language constructed with -extend-language is shown as if the language had been -constructed directly with `language'. If it is #f, then only -the last extension to the language is shown (with -four-period ellipses, just like in the concrete syntax). - -Defaultly #f. - -Note that the #t variant can look a little bit strange if -.... are used and the original version of the language has -multi-line right-hand sides. - -> reduction-relation->pict :: - (opt-> (reduction-relation?) - ((or/c false/c (listof (union string? symbol?)))) - pict?) - -> reduction-relation->ps :: - (opt-> (reduction-relation? - (union string? path?)) - ((or/c false/c (listof (union string? symbol?)))) - void?) - -These two functions turn reduction relations into picts. - -The optional lists determine which reduction rules are shown -in the pict. - -> (metafunction->pict metafunction-name) -> pict -> (metafunction->ps metafunction-name (union path? string?)) -> void - -These two syntactic forms turn metafunctions into picts - -There are also customization parameters: - -> rule-pict-style :: - (parameter/c (symbols 'vertical - 'compact-vertical - 'vertical-overlapping-side-conditions - 'horizontal)) - -This parameter controls the style used for the reduction -relation. It can be either horizontal, where the left and -right-hand sides of the reduction rule are beside each other -or vertical, where the left and right-hand sides of the -reduction rule are above each other. The vertical mode also -has a variant where the side-conditions don't contribute to -the width of the pict, but are just overlaid on the second -line of each rule. - -> arrow-space :: (parameter/c natural-number/c) - -This parameter controls the amount of extra horizontal space -around the reduction relation arrow. Defaults to 0. - -> horizontal-label-space :: (parameter/c natural-number/c) - -This parameter controls the amount of extra space before the -label on each rule, but only in horizontal mode. Defaults to -0. - -> metafunction-pict-style :: - (parameter/c (symbols 'left-right 'up-down)) - -This parameter controls the style used for typesetting -metafunctions. The 'left-right style means that the -results of calling the metafunction are displayed to the -right of the arguments and the 'up-down style means that -the results are displayed below the arguments. - -> label-style :: (parameter/c text-style/c) -> literal-style :: (parameter/c text-style/c) -> metafunction-style :: (parameter/c text-style/c) -> non-terminal-style :: (parameter/c text-style/c) -> non-terminal-subscript-style :: (parameter/c text-style/c) -> default-style :: (parameter/c text-style/c) - -These parameters determine the font used for various text in -the picts. See `text' in the texpict collection for -documentation explaining text-style/c. One of the more -useful things it can be is one of the symbols 'roman, -'swiss, or 'modern, which are a serif, sans-serif, and -monospaced font, respectively. (It can also encode style -information, too.) - -The label-style is used for the reduction rule label -names. The literal-style is used for names that aren't -non-terminals that appear in patterns. The -metafunction-style is used for the names of -metafunctions. The non-terminal-style is for non-terminals -and non-terminal-subscript-style is used for the portion -after the underscore in non-terminal references. - -The default-style is used for parenthesis, the dot in dotted -lists, spaces, the separator words in the grammar, the -"where" and "fresh" in side-conditions, and other places -where the other parameters aren't used. - -> label-font-size :: (parameter/c (and/c (between/c 1 255) integer?)) -> metafunction-font-size :: (parameter/c (and/c (between/c 1 255) integer?)) -> default-font-size :: (parameter/c (and/c (between/c 1 255) integer?)) - -These parameters control the various font sizes. The -default-font-size is used for all of the font sizes except -labels and metafunctions. - -> reduction-relation-rule-separation :: - (parameter/c (and/c integer? positive? exact?)) - -Controls the amount of space between clauses in a reduction -relation. Defaults to 4. - -> curly-quotes-for-strings :: (parameter/c boolean?) - -Controls if the open and close quotes for strings are turned -into “ and ” or are left as merely ". - -Defaults to #t. - -> current-text :: (parameter/c (-> string? text-style/c number? pict?)) - -This parameter's function is called whenever Redex typesets -some part of a grammar, reduction relation, or -metafunction. It defaults to mrpict.ss's `text' function. - -> set-arrow-pict! :: (-> symbol? (-> pict?) void?) - -This functions sets the pict for a given reduction-relation -symbol. When typesetting a reduction relation that uses the -symbol, the thunk will be invoked to get a pict to render -it. The thunk may be invoked multiple times when rendering a -single reduction relation. - -============================================================ - -_Removing the pink background from PLT Redex rendered picts and ps files_ -_Rewriting patterns during typesetting for PLT Redex_ - -When reduction rules, a metafunction, or a grammar contains -unquoted Scheme code or side-conditions, they are rendered -with a pink background as a guide to help find them and -provide alternative typesettings for them. In general, a -good goal for a PLT Redex program that you intend to typeset -is to only include such things when they correspond to -standard mathematical operations, and the Scheme code is an -implementation of those operations. - -To replace the pink code, use: - -> (with-unquote-rewriter proc expression) - -It installs `proc' the current unqoute rewriter and -evaluates expression. If that expression computes any picts, -the unquote rewriter specified is used to remap them. - -The 'proc' should be a function of one argument. It receives -a lw struct as an argument and should return -another lw that contains a rewritten version of the -code. - -> (with-atomic-rewriter name-symbol string-or-thunk-returning-pict expression) - -This extends the current set of atomic-rewriters with one -new one that rewrites the value of name-symbol to -string-or-pict-returning-thunk (applied, in the case of a -thunk), during the evaluation of expression. - -name-symbol is expected to evaluate to a symbol. The value -of string-or-thunk-returning-pict is used whever the symbol -appears in a pattern. - -> (with-compound-rewriter name-symbol proc expression) - -This extends the current set of compound-rewriters with one -new one that rewrites the value of name-symbol via proc, -during the evaluation of expression. - -name-symbol is expected to evaluate to a symbol. The value -of proc is called with a (listof lw) -- see below -for details on the shape of lw, and is expected to -return a new (listof (union lw string pict)), -rewritten appropriately. - -The list passed to the rewriter corresponds to the -lw for the sequence that has name-symbol's value at -its head. - -The result list is constrained to have at most 2 adjacent -non-lws. That list is then transformed by adding -lw structs for each of the non-lws in the -list (see the description of lw below for an -explanation of logical-space): - - 0: If there are two adjacent lws, then the logical - space between them is filled with whitespace. - - 1: If there is a pair of lws with just a single - non-lw between them, a lw will be - created (containing the non-lw) that uses all - of the available logical space between the lws. - - 2: If there are two adjacent non-lws between two - lws, the first non-lw is rendered - right after the first lw with a logical space - of zero, and the second is rendered right before the - last lw also with a logical space of zero, and - the logical space between the two lws is - absorbed by a new lw that renders using no - actual space in the typeset version. - -============================================================ - -The lw data structure corresponds represents a -pattern or a Scheme expression that is to be typeset. - -A _lw_ is a struct: - (build-lw element posnum posnum posnum posnum) -with selectors: -> lw-e :: lw -> element -> lw-line :: lw -> posnum -> lw-line-span :: lw -> posnum -> lw-column :: lw -> posnum -> lw-column-span :: lw -> posnum - -An _element_ is either: - string - symbol - pict - (listof lw) - -Each sub-expression corresponds to its own lw, and -the element indicates what kind of subexpression it is. If -the element is a list, then the lw corresponds to a -parenthesized sequence, and the list contains a lw -for the open paren, one lw for each component of the -sequence and then a lw for the close -parenthesis. In the case of a dotted list, there will also -be a lw in the third-to-last position for the dot. - -For example, this expression: - - (a) - -becomes this lw (assuming the above expression -appears as the first thing in the file): - - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw 'a 0 0 1 1) - (build-lw ")" 0 0 2 1)) - 0 0 0 3) - -If there is some whitespace in the sequence, like this one: - - (a b) - -then there is no lw that corresponds to that -whitespace; instead there is a logical gap between the -lws. - - (build-lw (list (build-lw "(" 0 0 0 1) - (build-lw 'a 0 0 1 1) - (build-lw 'b 0 0 3 1) - (build-lw ")" 0 0 4 1)) - 0 0 0 5) - -In general, identifiers are represented with symbols and -parenthesis are represented with strings and picts can be -inserted to render arbitrary pictures. - -The line, line-span, column, and column-span correspond to -the logical spacing for the redex program, not the actual -spacing that will be used when they are rendered. The -logical spacing is only used when determining where to place -typeset portions of the program. In the absense of any -rewriters, these numbers correspond to the line and column -numbers in the original program. - -The line and column are absolute numbers from the beginning -of the file containing the expression. The column number is -not necessarily the column of the open parenthesis in a -sequence -- it is the leftmost column that is occupied by -anything in the sequence. The line-span is the number of -lines, and the column span is the number of columns on the -last line (not the total width). - -When there are multiple lines, lines are aligned based on -the logical space (ie, the line/column & -line-span/column-span) fields of the lws. As an -example, if this is the original pattern: - - (all good boys - deserve fudge) - -then the leftmost edges of the words "good" and "deserve" -will be lined up underneath each other, but the relative -positions of "boys" and "fudge" will be determined by the -natural size of the words as they rendered in the -appropriate font. - -There are two helper functions that make building -lws easier: - -> just-before :: (-> (or/c pict? string? symbol?) - lw? - lw?) -> just-after :: (-> (or/c pict? string? symbol?) - lw? - lw?) - -These functions build new lws whose contents are -the first argument, and whose line and column are based on -the second argument, making the new loc wrapper be either -just before or just after that argument. The line-span and -column-span of the new lw is always zero. - -> (to-lw arg) SYNTAX - -This form turns its argument into lw structs that -contain all of the spacing information just as it would appear -when being used to typeset. - -====================================================================== - -The _iswim.ss_ module in the "examples" sub-collection defines a -grammar and reductions from "Programming Languages and Lambda Calculi" -by Felleisen and Flatt. - - Example S-expression forms of ISWIM expressions: - Book S-expr - ---- ------ - (lambda x . x) ("lam" x x) - (+ '1` '2`) ("+" 1 2) - ((lambda y y) '7`) (("lam" y y) 7) - - CK machine: - Book S-expr - ---- ------ - <(lambda x . x), mt> (("lam" x x) : "mt") - - CEK machine: - Book S-expr - ---- ------ - <<(lambda x . x), ((("lam" x x) - {>}>, : ((X (5 : ())))) - mt> : "mt") - - The full grammar: - - (language (M (M M) - (o1 M) - (o2 M M) - V) - (V X - ("lam" variable M) - b) - (X variable) - (b number) - (o1 "add1" "sub1" "iszero") - (o2 "+" "-" "*" "^") - (on o1 o2) - - ;; Evaluation contexts: - (E hole - (E M) - (V E) - (o1 E) - (o2 E M) - (o2 V E)) - - ;; Continuations (CK machine): - (k "mt" - ("fun" V k) - ("arg" M k) - ("narg" (V ... on) (M ...) k)) - - ;; Environments and closures (CEK): - (env ((X = vcl) ...)) - (cl (M : env)) - (vcl (V- : env)) - - ;; Values that are not variables: - (V- ("lam" variable M) - b) - - ;; Continuations with closures (CEK); - (k- "mt" - ("fun" vcl k-) - ("arg" cl k-) - ("narg" (vcl ... on) (cl ...) k-))) - - The following are provided by "iswim.ss": - - Grammar and substitution: -> iswim-grammar :: compiled-lang? -> M? :: (any? . -> . boolean?) -> V? :: (any? . -> . boolean?) -> o1? :: (any? . -> . boolean?) -> o2? :: (any? . -> . boolean?) -> on? :: (any? . -> . boolean?) -> k? :: (any? . -> . boolean?) -> env? :: (any? . -> . boolean?) -> cl? :: (any? . -> . boolean?) -> vcl? :: (any? . -> . boolean?) -> k-? :: (any? . -> . boolean?) -> iswim-subst :: (M? symbol? M? . -> . M?) -> empty-env :: env? -> env-extend :: (env? symbol? vcl? . -> . env?) -> env-lookup :: (env? symbol? . -> . (union false? vcl?)) - Reductions: -> beta_v :: reduction-relation? -> delta :: reduction-relation? -> ->v :: reduction-relation? -> :->v :: reduction-relation? - Abbreviations: -> if0 :: (M? M? M? . -> . M?) -> true :: M? -> false :: M? -> mkpair :: M? -> fst :: M? -> snd :: M? -> Y_v :: M? -> sum :: M? - Helpers: -> delta*1 :: (o1? V? . -> . (union false? V?)) - delta as a function for unary operations. -> delta*2 :: (o2? V? V? . -> . (union false? V?)) - delta as a function for binary operations. -> delta*n :: (on? (listof V?) . -> . (union false? V?)) - delta as a function for any operation. - diff --git a/collects/redex/examples/README b/collects/redex/examples/README new file mode 100644 index 0000000000..a4eafb380d --- /dev/null +++ b/collects/redex/examples/README @@ -0,0 +1,52 @@ +The examples subcollection contains several small languages +to demonstrate various different uses of PLT Redex: + + arithmetic.rkt: an arithmetic language with every + possible order of evaluation + + beginner.rkt: a PLT Redex implementation of (much of) the + beginning student teaching language. + + church.rkt: Church numerals with call by name + normal order evaluation + + combinators.rkt: fills in the gaps in a proof in + Barendregt that i and j (defined in the file) are + a combinator basis + + compatible-closure.rkt: an example use of compatible + closure. Also, one of the first examples from Matthias + Felleisen and Matthew Flatt's monograph + + contracts.rkt: A core contract calculus, including blame, + with function contracts, (eager) pair contracts, + and a few numeric predicates + + letrec.rkt: shows how to model letrec with a store and + some infinite looping terms + + omega.rkt: the call by value lambda calculus with call/cc. + Includes omega and two call/cc-based infinite loops, one of + which has an ever-expanding term size and one of which has + a bounded term size. + + pi-calculus.rkt: a formulation of the pi calculus, following + Milner's 1990 paper, "Functions as Processes" + + racket-machine: an operational semantics for (much of) Racket + bytecode + + r6rs: an implementation of the R6RS Scheme formal semantics + + semaphores.rkt: a simple threaded language with semaphores + + subject-reduction.rkt: demos traces/pred that type checks + the term. + + threads.rkt: shows how non-deterministic choice can be + modeled in a reduction semantics. Contains an example use + of a simple alternative pretty printer. + + types.rkt: shows how the simply-typed lambda calculus's + type system can be written as a rewritten system (see + Kuan, MacQueen, Findler in ESOP 2007 for more). diff --git a/collects/redex/examples/r6rs/README b/collects/redex/examples/r6rs/README index ec4e63e33b..3f7d63a0c8 100644 --- a/collects/redex/examples/r6rs/README +++ b/collects/redex/examples/r6rs/README @@ -1,4 +1,4 @@ -This directory contains the PLT Redex implementation of the +This directory a the PLT Redex implementation of the R6RS operational semantics and a test suite for the semantics. @@ -6,20 +6,20 @@ semantics. == r6rs-tests.ss: the test suite for the semantics. Use: - mzscheme -t r6rs-tests.ss -m + racket -t r6rs-tests.ss -m to run the tests and see a single period shown per test run (each test that explores more than 100 states shows a colon for each 100 states it explores). To see a more verbose output (that shows each test), use: - mzscheme -t r6rs-tests.ss -m #t + racket -t r6rs-tests.ss -m #t == show-examples.ss: use this file to explore particular examples in a GUI. Its content shows how to use it and gives a few examples. Either run it in DrRacket's module language, or like this from the commandline: - mred show-examples.ss + gracket show-examples.ss == test.ss: test suite infrastructure diff --git a/collects/redex/examples/r6rs/show-examples.rkt b/collects/redex/examples/r6rs/show-examples.rkt index 884c8c38db..11cf67973b 100644 --- a/collects/redex/examples/r6rs/show-examples.rkt +++ b/collects/redex/examples/r6rs/show-examples.rkt @@ -36,26 +36,21 @@ ;; example uses of the above functions ;; if any of the terms in the graph don't ;; match p*, they will be colored red -;; #; comments out an entire sexpression. ;; -#; (show '(store () (((lambda (x y) (set! x (+ x y)) x) 2 3)))) ;; an infinite, tail-recursive loop -#; (show-expression '((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc))) ;; two infinite loops, one in left-to-right and one in right-to-left evaluation order ;; one goes into a non-tail infinite loop, the other's reduction graph has a cycle -#; (step '(store () ((call/cc call/cc) (call/cc call/cc)))) ;; demonstrates sharing -#; (show-expression '((lambda (c) ((lambda (x y) From 4349df5b6a7702b72c1b6404d71f444939e5ca21 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 09:37:07 -0600 Subject: [PATCH 05/31] Fixing error when no email needs to be sent and changing addresses --- collects/meta/drdr/analyze.ss | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/collects/meta/drdr/analyze.ss b/collects/meta/drdr/analyze.ss index 826d63abcb..778aa04174 100644 --- a/collects/meta/drdr/analyze.ss +++ b/collects/meta/drdr/analyze.ss @@ -150,15 +150,18 @@ ; XXX But even then it can lead to problems (not (path-random? (build-path (revision-trunk-dir cur-rev) (substring (path->string* p) 1))))) (not (symbol=? id 'changes)))))) - (unless (andmap zero? nums) - (send-mail-message "drdr@plt-scheme.org" + (define mail-recipients + (append (if include-committer? + (list committer) + empty) + responsibles)) + (unless (or (andmap zero? nums) + (empty? mail-recipients)) + (send-mail-message "drdr@racket-lang.org" (format "[DrDr] R~a ~a" cur-rev totals) - (map (curry format "~a@plt-scheme.org") - (append (if include-committer? - (list committer) - empty) - responsibles)) + (map (curry format "~a@racket-lang.org") + mail-recipients) empty empty (flatten (list (format "DrDr has finished building push #~a after ~a." From 63df5311c5d86a7632826c9dc93a8bc541176f6d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 09:42:01 -0600 Subject: [PATCH 06/31] Racketizing --- collects/net/ftp-sig.rkt | 2 +- collects/net/ftp-unit.rkt | 4 ++-- collects/net/ftp.rkt | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/net/ftp-sig.rkt b/collects/net/ftp-sig.rkt index f177aef1ba..9572594234 100644 --- a/collects/net/ftp-sig.rkt +++ b/collects/net/ftp-sig.rkt @@ -1,4 +1,4 @@ -#lang scheme/signature +#lang racket/signature ftp-connection? ftp-cd diff --git a/collects/net/ftp-unit.rkt b/collects/net/ftp-unit.rkt index e008911e38..c821d9500d 100644 --- a/collects/net/ftp-unit.rkt +++ b/collects/net/ftp-unit.rkt @@ -1,10 +1,10 @@ -#lang scheme/unit +#lang racket/unit ;; Version 0.2 ;; Version 0.1a ;; Micah Flatt ;; 06-06-2002 -(require scheme/date scheme/file scheme/port scheme/tcp "ftp-sig.ss") +(require racket/date racket/file racket/port racket/tcp "ftp-sig.rkt") (import) (export ftp^) diff --git a/collects/net/ftp.rkt b/collects/net/ftp.rkt index 9a704ca76e..5e4ff2a349 100644 --- a/collects/net/ftp.rkt +++ b/collects/net/ftp.rkt @@ -1,5 +1,5 @@ -#lang scheme/base -(require scheme/unit "ftp-sig.ss" "ftp-unit.ss") +#lang racket/base +(require racket/unit "ftp-sig.rkt" "ftp-unit.rkt") (define-values/invoke-unit/infer ftp@) From 52281d7089eef6db8df1014e9607b39047adfb31 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 09:42:06 -0600 Subject: [PATCH 07/31] rkt suffixes --- collects/tests/net/main.rkt | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/tests/net/main.rkt b/collects/tests/net/main.rkt index a9db1e8a23..3942c70e4a 100644 --- a/collects/tests/net/main.rkt +++ b/collects/tests/net/main.rkt @@ -1,12 +1,12 @@ #lang scheme/base (require tests/eli-tester - (prefix-in ucodec: "uri-codec.ss") - (prefix-in url: "url.ss") - (prefix-in cgi: "cgi.ss") - (prefix-in head: "head.ss") - (prefix-in cookie: "cookie.ss") - (prefix-in encoders: "encoders.ss")) + (prefix-in ucodec: "uri-codec.rkt") + (prefix-in url: "url.rkt") + (prefix-in cgi: "cgi.rkt") + (prefix-in head: "head.rkt") + (prefix-in cookie: "cookie.rkt") + (prefix-in encoders: "encoders.rkt")) (define (tests) (test do (begin (url:tests) From 15d9a7dd8a43b595362701eca5c06ea7df093294 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 09:55:20 -0600 Subject: [PATCH 08/31] Initial ftp test cases --- collects/tests/net/ftp.rkt | 29 +++++++++++++++++++++++++++++ collects/tests/net/main.rkt | 2 ++ 2 files changed, 31 insertions(+) create mode 100644 collects/tests/net/ftp.rkt diff --git a/collects/tests/net/ftp.rkt b/collects/tests/net/ftp.rkt new file mode 100644 index 0000000000..03e0f1eb8d --- /dev/null +++ b/collects/tests/net/ftp.rkt @@ -0,0 +1,29 @@ +#lang racket +(require net/ftp tests/eli-tester) + +(define server "ftp.gnu.org") +(define port 21) +(define user "anonymous") +(define passwd "nonny") + +(provide tests) +(define (tests) + (define conn #f) + (define pth "=README-about-.diff-files") + (define tmp-dir (make-temporary-file "ftp~a" 'directory)) + (test (ftp-connection? 1) => #f + (set! conn (ftp-establish-connection server port user passwd)) + (ftp-connection? conn) + (ftp-cd conn "gnu") + (for ([f (in-list (ftp-directory-list conn))]) + (match-define (list type ftp-date name) f) + (test + (ftp-make-file-seconds ftp-date))) + + (ftp-download-file conn tmp-dir pth) + (delete-file (build-path tmp-dir pth)) + (delete-directory/files tmp-dir) + + (ftp-close-connection conn))) + +(tests) \ No newline at end of file diff --git a/collects/tests/net/main.rkt b/collects/tests/net/main.rkt index 3942c70e4a..ec83b24f7d 100644 --- a/collects/tests/net/main.rkt +++ b/collects/tests/net/main.rkt @@ -4,6 +4,7 @@ (prefix-in ucodec: "uri-codec.rkt") (prefix-in url: "url.rkt") (prefix-in cgi: "cgi.rkt") + (prefix-in ftp: "ftp.rkt") (prefix-in head: "head.rkt") (prefix-in cookie: "cookie.rkt") (prefix-in encoders: "encoders.rkt")) @@ -12,6 +13,7 @@ (test do (begin (url:tests) (ucodec:tests) (cgi:tests) + (ftp:tests) (head:tests) (cookie:tests) (encoders:tests)))) From f5bddf770508a4b8be0cf8e22414363ff6348538 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 09:56:15 -0600 Subject: [PATCH 09/31] Fixing ftp-download-file --- collects/net/ftp-unit.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/net/ftp-unit.rkt b/collects/net/ftp-unit.rkt index c821d9500d..009d4709fc 100644 --- a/collects/net/ftp-unit.rkt +++ b/collects/net/ftp-unit.rkt @@ -197,7 +197,7 @@ (path->string (build-path folder "ftptmp")) "~~") "~a"))] - [new-file (open-output-file tmpfile 'replace)] + [new-file (open-output-file tmpfile #:exists 'replace)] [tcpstring (bytes-append #"RETR " (string->bytes/locale filename) #"\n")] From 85a7509034b964e7eff66a1b19da35da32285745 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 09:56:17 -0600 Subject: [PATCH 10/31] Removing test auto run --- collects/tests/net/ftp.rkt | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/collects/tests/net/ftp.rkt b/collects/tests/net/ftp.rkt index 03e0f1eb8d..511586b168 100644 --- a/collects/tests/net/ftp.rkt +++ b/collects/tests/net/ftp.rkt @@ -24,6 +24,4 @@ (delete-file (build-path tmp-dir pth)) (delete-directory/files tmp-dir) - (ftp-close-connection conn))) - -(tests) \ No newline at end of file + (ftp-close-connection conn))) \ No newline at end of file From c3f5aed473e86d486e71a633e7caee8f22338b0c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 22 May 2010 08:47:54 -0600 Subject: [PATCH 11/31] fix docs for in-directory to specific default argument value Merge to v5.0 --- collects/scribblings/reference/sequences.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index 80315d5a02..8a66923493 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -193,7 +193,7 @@ its value from @scheme[hash] (as opposed to using @scheme[hash] directly as a sequence to get the key and value as separate values for each element).} -@defproc[(in-directory [dir (or/c #f path-string?)]) sequence?]{ +@defproc[(in-directory [dir (or/c #f path-string?) #f]) sequence?]{ Return a sequence that produces all of the paths for files, directories, and links with @racket[dir]. If @racket[dir] is not From 0b8a664d7828f47d9373101ebfefa2b9fe0a9f75 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 24 May 2010 06:57:16 -0600 Subject: [PATCH 12/31] fix minor doc bugs --- collects/scribblings/reference/numbers.scrbl | 6 +++--- collects/scribblings/reference/pretty-print.scrbl | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl index be4da64c9a..7ae7ac24be 100644 --- a/collects/scribblings/reference/numbers.scrbl +++ b/collects/scribblings/reference/numbers.scrbl @@ -253,8 +253,8 @@ otherwise.} @mz-examples[(remainder 10 3) (remainder -10.0 3) (remainder 10.0 -3) (remainder -10 -3) (remainder +inf.0 3)]} -@defproc[(quotient/remainder [n integer?] [m integer?]) (values number? number?)]{ Returns - @racket[(values (quotient n m) (remainder n m))], but the combination is computed +@defproc[(quotient/remainder [n integer?] [m integer?]) (values integer? integer?)]{ Returns + @racket[(values (quotient n m) (remainder n m))], but the combination may be computed more efficiently than separate calls to @racket[quotient] and @racket[remainder]. @mz-examples[ @@ -262,7 +262,7 @@ otherwise.} ]} -@defproc[(modulo [n integer?] [m integer?]) number?]{ Returns +@defproc[(modulo [n integer?] [m integer?]) integer?]{ Returns @racket[_q] with the same sign as @racket[m] where @itemize[ diff --git a/collects/scribblings/reference/pretty-print.scrbl b/collects/scribblings/reference/pretty-print.scrbl index 6af9aabab3..0764539702 100644 --- a/collects/scribblings/reference/pretty-print.scrbl +++ b/collects/scribblings/reference/pretty-print.scrbl @@ -20,7 +20,7 @@ In addition to the parameters defined in this section, @scheme[pretty-print] conforms to the @scheme[print-graph], @scheme[print-struct], @scheme[print-hash-table], @scheme[print-vector-length], @scheme[print-box], and -@scheme[print-as-quasiquote] parameters. +@scheme[print-as-expression] parameters. The pretty printer detects structures that have the @scheme[prop:custom-write] property and it calls the corresponding From 6dec67730837b512d5cb0e258a4c48599ef656a1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 24 May 2010 10:01:12 -0600 Subject: [PATCH 13/31] Fix problem with scribble/lp and dotted forms Closes PR 10924 Merge to v5.0 --- collects/scribble/lp/lang/lang.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribble/lp/lang/lang.rkt b/collects/scribble/lp/lang/lang.rkt index f8eb1491b6..640849a0bc 100644 --- a/collects/scribble/lp/lang/lang.rkt +++ b/collects/scribble/lp/lang/lang.rkt @@ -41,7 +41,7 @@ (raise-syntax-error 'scribble/lp "no chunks"))) (define orig-stx (syntax-case stx () [(_ orig) #'orig])) (define (restore nstx d) (datum->syntax orig-stx d nstx nstx)) - (define (shift nstx) (datum->syntax orig-stx (syntax-e nstx) nstx nstx)) + (define (shift nstx) (replace-context orig-stx nstx)) (define body (let ([main-id (or main-id first-id)]) (restore From 77841f0834ea23f42b3b1b0e4f937ae27b333b90 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 24 May 2010 12:17:23 -0500 Subject: [PATCH 14/31] fixes PR 19025 --- collects/2htdp/private/image-more.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index 48d1fb1360..f42d068d7c 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -352,7 +352,7 @@ ;; scale : I number -> I ;; scales the I by the given factor -;; rotate : I number -> I +;; rotate : number I -> I ;; rotates the I around the top-left corner by the given angle (in degrees) (define/chk (rotate angle image) (let* ([rotated-shape (rotate-normalized-shape From 387f915f2464e994327387dd0944e0f8378c8b8a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:32:47 -0600 Subject: [PATCH 15/31] Adding local change note --- src/foreign/README | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/foreign/README b/src/foreign/README index c1f4e1645d..d47657ab5b 100644 --- a/src/foreign/README +++ b/src/foreign/README @@ -35,6 +35,9 @@ Local changes: git master source at http://github.com/atgreen/libffi/, tree 997968323ed45a5ea5db1ff83124619ae1949bfb. (r18350) + * Observing ftruncate result in closures.c to remove warning. (commit + b5ee4ac21b1c4d759659 and c64704742c0963310b49) + Note: recreating "configure" with autoconf 2.61 does not work as is, since the scripts require 2.59. To allow this, the two requirements in "libffi/configure.ac" and "config/override.m4" were temporarily From 61f03beaee21de074067c166d9b3d349bac1fff6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 24 May 2010 12:42:17 -0500 Subject: [PATCH 16/31] fixed problems with chat noir's h key implementation (and added a note about the new 'n' key) --- .../games/chat-noir/chat-noir-literate.rkt | 69 +++++++++++++++---- 1 file changed, 55 insertions(+), 14 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.rkt b/collects/games/chat-noir/chat-noir-literate.rkt index 13066aa9a2..e72016f0c4 100644 --- a/collects/games/chat-noir/chat-noir-literate.rkt +++ b/collects/games/chat-noir/chat-noir-literate.rkt @@ -16,6 +16,9 @@ that space, and the cat responds by taking a step. If the cat is completely boxed in and thus unable reach the border, you win. If the cat does reach the border, you lose. +To start a new game, hit the ``n'' key (but only after losing or +winning a game). + @play-margin-note["Chat Noir"] To get some insight into the cat's behavior, hold down the ``h'' @@ -57,8 +60,8 @@ and some code that builds an initial world and starts the game. - + ] Each section also comes with a series of test cases that are collected into the @@ -1098,6 +1101,7 @@ plus various helper functions. @chunk[ + @@ -1110,6 +1114,7 @@ plus various helper functions. @chunk[ + @@ -1118,22 +1123,41 @@ plus various helper functions. ] -The @scheme[change] function handles keyboard input and merely updates the @tt{h-down?} field -based on the state of the key event during gameplay. Once the game has ended it resets to the -initial world when the user presses @litchar{n}. +The @scheme[change] function handles keyboard input. If the input is @litchar{n} and the +game is over, then restart the game. If the input is @litchar{h} then turn on the help +and otherwise do nothing. @chunk[ ;; change : world key-event -> world (define (change w ke) - (if (and (not (equal? (world-state w) 'playing)) - (key=? ke "n")) - (make-initial-world) - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - (world-mouse-posn w) - (key=? ke "h"))))] + (cond + [(key=? ke "n") + (if (equal? (world-state w) 'playing) + w + (make-initial-world))] + [(key=? ke "h") + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + (world-mouse-posn w) + #t)] + [else w]))] + +The @scheme[release] function adjusts the world for a key release event. + +@chunk[ + ;; release : world key-event -> world + (define (release w ke) + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + (world-mouse-posn w) + (if (key=? ke "h") + #f + (world-h-down? w))))] + The @scheme[clack] function handles mouse input. It has three tasks and each corresponds to a helper function: @@ -2253,7 +2277,23 @@ and reports the results. 'playing 3 (make-posn 0 0) #f) "h") (make-world '() (make-posn 1 1) - 'playing 3 (make-posn 0 0) #t))] + 'playing 3 (make-posn 0 0) #t)) + (test (change (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) #f) + "n") + (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) #f)) + (test (world-state (change (make-world '() (make-posn 1 1) + 'cat-lost 3 (make-posn 0 0) #f) + "n")) + 'playing)] + +@chunk[ + (test (release (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) #t) + "h") + (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) #f))] @chunk[ @@ -2362,5 +2402,6 @@ by calling @scheme[big-bang] with the appropriate arguments. (world-width board-size) (world-height board-size)) (on-key change) + (on-release release) (on-mouse clack) (name "Chat Noir"))))] From 3b98c8f9b3f9a8b02b68de78fb8a71c35904d66a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:38:32 -0600 Subject: [PATCH 17/31] Syntax objects are supported --- collects/scribblings/raco/decompile.scrbl | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/scribblings/raco/decompile.scrbl b/collects/scribblings/raco/decompile.scrbl index 74687c4c81..24184516f6 100644 --- a/collects/scribblings/raco/decompile.scrbl +++ b/collects/scribblings/raco/decompile.scrbl @@ -135,6 +135,5 @@ Consumes the result of parsing bytecode and returns an S-expression @defproc[(zo-marshal [top compilation-top?]) bytes?]{ Consumes a representation of bytecode and generates a byte string for -the marshaled bytecode. Currently, syntax objects are not supported, -including in @racket[req] for a top-level @racket[#%require].} +the marshaled bytecode.} From b892c276ffebeb35eb3130e5865c312d7fe1f592 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:48:19 -0600 Subject: [PATCH 18/31] Streaming final output from zo-marshal --- collects/compiler/zo-marshal.rkt | 43 ++++++++++++++++++-------------- 1 file changed, 24 insertions(+), 19 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 0e8276b586..313561f857 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1,11 +1,14 @@ #lang scheme/base (require compiler/zo-structs scheme/match + scheme/contract scheme/local scheme/list scheme/dict) -(provide zo-marshal) +(provide/contract + [zo-marshal (compilation-top? . -> . bytes?)] + [zo-marshal-to (compilation-top? output-port? . -> . void?)]) #| Unresolved Issues @@ -16,6 +19,11 @@ (define current-wrapped-ht (make-parameter #f)) (define (zo-marshal top) + (define bs (open-output-bytes)) + (zo-marshal-to top bs) + (get-output-bytes bs)) + +(define (zo-marshal-to top outp) (match top [(struct compilation-top (max-let-depth prefix form)) (let ([encountered (make-hasheq)] @@ -61,24 +69,21 @@ (out-data (list* max-let-depth prefix (protect-quote form)) out) (let ([res (get-output-bytes s)] [version-bs (string->bytes/latin-1 (version))]) - (bytes-append #"#~" - (bytes (bytes-length version-bs)) - version-bs - (int->bytes (add1 (hash-count shared))) - (bytes (if all-short? - 1 - 0)) - (apply - bytes-append - (map (lambda (o) - (integer->integer-bytes o - (if all-short? 2 4) - #f - #f)) - offsets)) - (int->bytes post-shared) - (int->bytes (bytes-length res)) - res))))])) + (write-bytes #"#~" outp) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + (write-bytes (int->bytes (add1 (hash-count shared))) outp) + (write-bytes (bytes (if all-short? + 1 + 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o + (if all-short? 2 4) + #f + #f) outp)) + (write-bytes (int->bytes post-shared) outp) + (write-bytes (int->bytes (bytes-length res)) outp) + (write-bytes res outp))))])) ;; ---------------------------------------- From 63f546a0808c81191392428e8dd7d1b972fc3f02 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:55:49 -0600 Subject: [PATCH 19/31] Reformating --- collects/compiler/zo-marshal.rkt | 111 +++++++++++++++---------------- 1 file changed, 53 insertions(+), 58 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 313561f857..39c06bb90f 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -26,64 +26,59 @@ (define (zo-marshal-to top outp) (match top [(struct compilation-top (max-let-depth prefix form)) - (let ([encountered (make-hasheq)] - [shared (make-hasheq)] - [wrapped (make-hasheq)]) - (let ([visit (lambda (v) - (if (hash-ref shared v #f) - #f - (if (hash-ref encountered v #f) - (begin - (hash-set! shared v (add1 (hash-count shared))) - #f) - (begin - (hash-set! encountered v #t) - (when (closure? v) - (hash-set! shared v (add1 (hash-count shared)))) - #t))))]) - (parameterize ([current-wrapped-ht wrapped]) - (traverse-prefix prefix visit) - (traverse-form form visit))) - (let* ([s (open-output-bytes)] - [out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] - [offsets - (map (lambda (v) - (let ([v (cdr v)]) - (begin0 - (file-position s) - (out-anything v (make-out - s - (let ([skip? #t]) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (hash-ref shared v2 #f)))) - wrapped))))) - (sort (hash-map shared (lambda (k v) (cons v k))) - < - #:key car))] - [post-shared (file-position s)] - [all-short? (post-shared . < . #xFFFF)]) - (out-data (list* max-let-depth prefix (protect-quote form)) out) - (let ([res (get-output-bytes s)] - [version-bs (string->bytes/latin-1 (version))]) - (write-bytes #"#~" outp) - (write-bytes (bytes (bytes-length version-bs)) outp) - (write-bytes version-bs outp) - (write-bytes (int->bytes (add1 (hash-count shared))) outp) - (write-bytes (bytes (if all-short? - 1 - 0)) outp) - (for ([o (in-list offsets)]) - (write-bytes (integer->integer-bytes o - (if all-short? 2 4) - #f - #f) outp)) - (write-bytes (int->bytes post-shared) outp) - (write-bytes (int->bytes (bytes-length res)) outp) - (write-bytes res outp))))])) + (define encountered (make-hasheq)) + (define shared (make-hasheq)) + (define wrapped (make-hasheq)) + (define (visit v) + (if (hash-ref shared v #f) + #f + (if (hash-ref encountered v #f) + (begin + (hash-set! shared v (add1 (hash-count shared))) + #f) + (begin + (hash-set! encountered v #t) + (when (closure? v) + (hash-set! shared v (add1 (hash-count shared)))) + #t)))) + (parameterize ([current-wrapped-ht wrapped]) + (traverse-prefix prefix visit) + (traverse-form form visit)) + (let* ([s (open-output-bytes)] + [out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] + [offsets + (map (lambda (v) + (let ([v (cdr v)]) + (begin0 + (file-position s) + (out-anything v (make-out + s + (let ([skip? #t]) + (lambda (v2) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (hash-ref shared v2 #f)))) + wrapped))))) + (sort (hash-map shared (lambda (k v) (cons v k))) + < + #:key car))] + [post-shared (file-position s)] + [all-short? (post-shared . < . #xFFFF)] + [version-bs (string->bytes/latin-1 (version))]) + (out-data (list* max-let-depth prefix (protect-quote form)) out) + (let ([res (get-output-bytes s)]) + (write-bytes #"#~" outp) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + (write-bytes (int->bytes (add1 (hash-count shared))) outp) + (write-bytes (bytes (if all-short? 1 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) + (write-bytes (int->bytes post-shared) outp) + (write-bytes (int->bytes (bytes-length res)) outp) + (write-bytes res outp)))])) ;; ---------------------------------------- From cb5aac762ef5f767e81d49d991e5dc2ec8be971d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:56:15 -0600 Subject: [PATCH 20/31] Adding stream output --- collects/scribblings/raco/decompile.scrbl | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/scribblings/raco/decompile.scrbl b/collects/scribblings/raco/decompile.scrbl index 24184516f6..cacf906532 100644 --- a/collects/scribblings/raco/decompile.scrbl +++ b/collects/scribblings/raco/decompile.scrbl @@ -132,6 +132,10 @@ Consumes the result of parsing bytecode and returns an S-expression @defmodule[compiler/zo-marshal] +@defproc[(zo-marshal-to [top compilation-top?] [out output-port?]) void?]{ + +Consumes a representation of bytecode and writes it to @racket[out].} + @defproc[(zo-marshal [top compilation-top?]) bytes?]{ Consumes a representation of bytecode and generates a byte string for From 325ac1ae88644f90e34f51d8090fcebdb36e3a3c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:58:55 -0600 Subject: [PATCH 21/31] Reformating --- collects/compiler/zo-marshal.rkt | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 39c06bb90f..7679c97236 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -47,20 +47,20 @@ (let* ([s (open-output-bytes)] [out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] [offsets - (map (lambda (v) - (let ([v (cdr v)]) - (begin0 - (file-position s) - (out-anything v (make-out - s - (let ([skip? #t]) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (hash-ref shared v2 #f)))) - wrapped))))) + (map (lambda (k*v) + (define v (cdr k*v)) + (begin0 + (file-position s) + (out-anything v (make-out + s + (let ([skip? #t]) + (lambda (v2) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (hash-ref shared v2 #f)))) + wrapped)))) (sort (hash-map shared (lambda (k v) (cons v k))) < #:key car))] From f44e3123b5209c72d71527a23e73d692a8c53d25 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 12:45:12 -0600 Subject: [PATCH 22/31] Adding byte counting ports --- collects/meta/props | 3 +++ collects/tests/unstable/byte-counting-port.rkt | 15 +++++++++++++++ collects/unstable/byte-counting-port.rkt | 17 +++++++++++++++++ .../scribblings/byte-counting-port.scrbl | 15 +++++++++++++++ collects/unstable/scribblings/unstable.scrbl | 1 + 5 files changed, 51 insertions(+) create mode 100644 collects/tests/unstable/byte-counting-port.rkt create mode 100644 collects/unstable/byte-counting-port.rkt create mode 100644 collects/unstable/scribblings/byte-counting-port.scrbl diff --git a/collects/meta/props b/collects/meta/props index a572485568..3f4592ac39 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1800,6 +1800,7 @@ path/s is either such a string or a list of them. "collects/tests/units/test-runtime.rktl" drdr:command-line (racket "-f" *) "collects/tests/units/test-unit-contracts.rktl" drdr:command-line (racket "-f" *) "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/srcloc.rktl" responsible (cce) drdr:command-line (racket "-f" *) "collects/tests/utils" responsible (unknown) @@ -1839,6 +1840,7 @@ path/s is either such a string or a list of them. "collects/typed/rackunit/gui.rkt" drdr:command-line (gracket "-t" *) "collects/typed-scheme" responsible (samth) "collects/unstable" responsible (jay samth cce ryanc) +"collects/unstable/byte-counting-port.rkt" responsible (jay) "collects/unstable/debug.rkt" responsible (samth) "collects/unstable/gui/notify.rkt" drdr:command-line (gracket-text "-t" *) "collects/unstable/gui/prefs.rkt" drdr:command-line (gracket-text "-t" *) @@ -1846,6 +1848,7 @@ path/s is either such a string or a list of them. "collects/unstable/match.rkt" responsible (samth) "collects/unstable/mutated-vars.rkt" responsible (samth) "collects/unstable/poly-c.rkt" responsible (samth) +"collects/unstable/scribblings/byte-counting-port.scrbl" responsible (jay) "collects/unstable/scribblings/debug.scrbl" responsible (samth) "collects/unstable/scribblings/hash.scrbl" responsible (samth) "collects/unstable/scribblings/match.scrbl" responsible (samth) diff --git a/collects/tests/unstable/byte-counting-port.rkt b/collects/tests/unstable/byte-counting-port.rkt new file mode 100644 index 0000000000..bf98c31873 --- /dev/null +++ b/collects/tests/unstable/byte-counting-port.rkt @@ -0,0 +1,15 @@ +#lang racket +(require unstable/byte-counting-port + tests/eli-tester) + +(define name (gensym)) +(define cp (make-byte-counting-port name)) +(test + (object-name cp) => name + (for/fold ([l 0]) + ([i (in-range 100)]) + (define n (random 25)) + (test + (file-position cp) => l + (write-bytes (make-bytes n) cp)) + (+ l n))) \ No newline at end of file diff --git a/collects/unstable/byte-counting-port.rkt b/collects/unstable/byte-counting-port.rkt new file mode 100644 index 0000000000..d0de94c8da --- /dev/null +++ b/collects/unstable/byte-counting-port.rkt @@ -0,0 +1,17 @@ +#lang racket + +(define (make-byte-counting-port [name 'byte-counting-port]) + (define location 0) + (define (write-out bs starting ending opt1 opt2) + (define how-many-written (- ending starting)) + (set! location (+ location how-many-written)) + how-many-written) + (define close void) + (define (get-location) + (values #f #f location)) + (make-output-port name always-evt write-out close + #f #f #f + get-location)) + +(provide/contract + [make-byte-counting-port (any/c . -> . output-port?)]) \ No newline at end of file diff --git a/collects/unstable/scribblings/byte-counting-port.scrbl b/collects/unstable/scribblings/byte-counting-port.scrbl new file mode 100644 index 0000000000..17047a6ae0 --- /dev/null +++ b/collects/unstable/scribblings/byte-counting-port.scrbl @@ -0,0 +1,15 @@ +#lang scribble/manual +@(require "utils.rkt" (for-label racket unstable/byte-counting-port)) + +@title{Byte Counting Ports} + +@defmodule[unstable/byte-counting-port] + +@unstable[@author+email["Jay McCarthy" "jay@racket-lang.org"]] + +This library provides an output port constructor like @racket[open-output-nowhere], except it counts how many bytes have been written (available through @racket[file-position].) + +@defproc[(make-byte-counting-port [name any/c 'byte-counting-port]) + output-port?]{ +Creates and returns an output port that discards all output sent to it (without blocking.) The @racket[name] argument is used as the port's name. The total number bytes written is available through @racket[file-position].} + \ No newline at end of file diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 19b157a98e..3fb0d3f56b 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -95,6 +95,7 @@ Keep documentation and tests up to date. @include-section["generics.scrbl"] @include-section["markparam.scrbl"] @include-section["debug.scrbl"] +@include-section["byte-counting-port.scrbl"] @;{--------} From 40e1ba95fc6bd592800ec5a565b2bc8eba13c562 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 12:45:42 -0600 Subject: [PATCH 23/31] Making zo-marshal more like C and not with large byte strings --- collects/compiler/zo-marshal.rkt | 75 +++++++++++++++++--------------- 1 file changed, 40 insertions(+), 35 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 7679c97236..5fbf347c94 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1,5 +1,6 @@ #lang scheme/base (require compiler/zo-structs + unstable/byte-counting-port scheme/match scheme/contract scheme/local @@ -41,44 +42,48 @@ (when (closure? v) (hash-set! shared v (add1 (hash-count shared)))) #t)))) + (define (v-skipping v) + (define skip? #t) + (lambda (v2) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (hash-ref shared v2 #f)))) (parameterize ([current-wrapped-ht wrapped]) (traverse-prefix prefix visit) (traverse-form form visit)) - (let* ([s (open-output-bytes)] - [out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] - [offsets - (map (lambda (k*v) - (define v (cdr k*v)) - (begin0 - (file-position s) - (out-anything v (make-out - s - (let ([skip? #t]) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (hash-ref shared v2 #f)))) - wrapped)))) - (sort (hash-map shared (lambda (k v) (cons v k))) - < - #:key car))] - [post-shared (file-position s)] - [all-short? (post-shared . < . #xFFFF)] - [version-bs (string->bytes/latin-1 (version))]) - (out-data (list* max-let-depth prefix (protect-quote form)) out) - (let ([res (get-output-bytes s)]) - (write-bytes #"#~" outp) - (write-bytes (bytes (bytes-length version-bs)) outp) - (write-bytes version-bs outp) - (write-bytes (int->bytes (add1 (hash-count shared))) outp) - (write-bytes (bytes (if all-short? 1 0)) outp) - (for ([o (in-list offsets)]) - (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) - (write-bytes (int->bytes post-shared) outp) - (write-bytes (int->bytes (bytes-length res)) outp) - (write-bytes res outp)))])) + (local [(define in-order-shareds + (sort (hash-map shared (lambda (k v) (cons v k))) + < + #:key car)) + (define (write-all outp) + (define offsets + (for/list ([k*v (in-list in-order-shareds)]) + (define v (cdr k*v)) + (begin0 + (file-position outp) + (out-anything v (make-out outp (v-skipping v) wrapped))))) + (define post-shared (file-position outp)) + (out-data (list* max-let-depth prefix (protect-quote form)) + (make-out outp (lambda (v) (hash-ref shared v #f)) wrapped)) + (values offsets post-shared (file-position outp))) + (define counting-p (make-byte-counting-port)) + (define-values (offsets post-shared all-forms-length) + (write-all counting-p)) + (define all-short? (post-shared . < . #xFFFF)) + (define version-bs (string->bytes/latin-1 (version)))] + (write-bytes #"#~" outp) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + (write-bytes (int->bytes (add1 (hash-count shared))) outp) + (write-bytes (bytes (if all-short? 1 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) + (write-bytes (int->bytes post-shared) outp) + (write-bytes (int->bytes all-forms-length) outp) + (write-all outp) + (void))])) ;; ---------------------------------------- From 758b9449960cd42915936b7e83d557affbf18504 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 12:56:04 -0600 Subject: [PATCH 24/31] Contract was too strict --- collects/tests/unstable/byte-counting-port.rkt | 17 ++++++++++------- collects/unstable/byte-counting-port.rkt | 2 +- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/collects/tests/unstable/byte-counting-port.rkt b/collects/tests/unstable/byte-counting-port.rkt index bf98c31873..92f122b54a 100644 --- a/collects/tests/unstable/byte-counting-port.rkt +++ b/collects/tests/unstable/byte-counting-port.rkt @@ -4,12 +4,15 @@ (define name (gensym)) (define cp (make-byte-counting-port name)) +(define (test-cp cp) + (for/fold ([l 0]) + ([i (in-range 100)]) + (define n (random 25)) + (test + (file-position cp) => l + (write-bytes (make-bytes n) cp)) + (+ l n))) (test (object-name cp) => name - (for/fold ([l 0]) - ([i (in-range 100)]) - (define n (random 25)) - (test - (file-position cp) => l - (write-bytes (make-bytes n) cp)) - (+ l n))) \ No newline at end of file + (test-cp cp) + (test-cp (make-byte-counting-port))) \ No newline at end of file diff --git a/collects/unstable/byte-counting-port.rkt b/collects/unstable/byte-counting-port.rkt index d0de94c8da..17949a9d2d 100644 --- a/collects/unstable/byte-counting-port.rkt +++ b/collects/unstable/byte-counting-port.rkt @@ -14,4 +14,4 @@ get-location)) (provide/contract - [make-byte-counting-port (any/c . -> . output-port?)]) \ No newline at end of file + [make-byte-counting-port (() (any/c) . ->* . output-port?)]) \ No newline at end of file From f67177f7408571c027a8e4040509499c059eb10c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 12:57:32 -0600 Subject: [PATCH 25/31] Separating bytes usage for next change --- collects/compiler/zo-parse.rkt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 801430206a..a048f20489 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -361,6 +361,10 @@ (define-struct cport ([pos #:mutable] shared-start orig-port size bytes symtab shared-offsets decoded rns mpis)) +(define (cport-get-bytes cp len) + (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))) +(define (cport-get-byte cp pos) + (bytes-ref (cport-bytes cp) pos)) (define (cport-rpos cp) (+ (cport-pos cp) (cport-shared-start cp))) @@ -369,8 +373,7 @@ (begin-with-definitions (when ((cport-pos cp) . >= . (cport-size cp)) (error "off the end")) - (define r - (bytes-ref (cport-bytes cp) (cport-pos cp))) + (define r (cport-get-byte cp (cport-pos cp))) (set-cport-pos! cp (add1 (cport-pos cp))) r)) @@ -436,7 +439,7 @@ (define (read-compact-bytes port c) (begin0 - (subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos port) c)) + (cport-get-bytes port c) (set-cport-pos! port (+ c (cport-pos port))))) (define (read-compact-chars port c) @@ -742,7 +745,7 @@ v)))] [(escape) (let* ([len (read-compact-number cp)] - [s (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))]) + [s (cport-get-bytes cp len)]) (set-cport-pos! cp (+ (cport-pos cp) len)) (parameterize ([read-accept-compiled #t] [read-accept-bar-quote #t] From 2a934cb0539bc28442b0eaeb91c68afc866f7977 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 13:12:57 -0600 Subject: [PATCH 26/31] Do not read the entire zo at once --- collects/compiler/decompile.rkt | 9 +++++---- collects/compiler/zo-parse.rkt | 23 +++++++++++++---------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index e6d8e0aa48..f10d8737ac 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require compiler/zo-parse syntax/modcollapse + scheme/port scheme/match) (provide decompile) @@ -21,10 +22,10 @@ [table (make-hash)]) (for ([b (in-list bindings)]) (let ([v (and (cdr b) - (zo-parse (let-values ([(in out) (make-pipe)]) - (write (cdr b) out) - (close-output-port out) - in)))]) + (zo-parse + (open-input-bytes + (with-output-to-bytes + (λ () (write (cdr b)))))))]) (let ([n (match v [(struct compilation-top (_ prefix (struct primval (n)))) n] [else #f])]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index a048f20489..6f1b338560 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -359,12 +359,16 @@ (define (read-simple-number p) (integer-bytes->integer (read-bytes 4 p) #f #f)) - -(define-struct cport ([pos #:mutable] shared-start orig-port size bytes symtab shared-offsets decoded rns mpis)) +(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets decoded rns mpis)) (define (cport-get-bytes cp len) - (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))) + (define port (cport-orig-port cp)) + (define pos (cport-pos cp)) + (file-position port (+ (cport-bytes-start cp) pos)) + (read-bytes len port)) (define (cport-get-byte cp pos) - (bytes-ref (cport-bytes cp) pos)) + (define port (cport-orig-port cp)) + (file-position port (+ (cport-bytes-start cp) pos)) + (read-byte port)) (define (cport-rpos cp) (+ (cport-pos cp) (cport-shared-start cp))) @@ -979,17 +983,16 @@ (when (shared-size . >= . size*) (error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)")) - (define rst (read-bytes size* port)) + (define rst-start (file-position port)) + + (file-position port (+ rst-start size*)) (unless (eof-object? (read-byte port)) - (error 'not-end)) - - (unless (= size* (bytes-length rst)) - (error "wrong number of bytes")) + (error 'zo-parse "File too big")) (define symtab (make-vector symtabsize (make-not-ready))) - (define cp (make-cport 0 shared-size port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) + (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)) From 4d892983faa04b59d9d9db0af96d8228ab52f5f3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 14:21:46 -0600 Subject: [PATCH 27/31] Adding test cases to verify changes --- collects/tests/racket/date.rktl | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/collects/tests/racket/date.rktl b/collects/tests/racket/date.rktl index 2e24303fa0..074d38f5a3 100644 --- a/collects/tests/racket/date.rktl +++ b/collects/tests/racket/date.rktl @@ -19,6 +19,32 @@ (test-find 0 0 0 1 4 1975) (test-find 0 0 0 1 4 2005) +; date->string +(let ([d (seconds->date (find-seconds 1 2 3 4 5 2006))]) + (define (test-string fmt time? result) + (test (parameterize ([date-display-format fmt]) + (date->string d time?)) + fmt result)) + (test-string 'american #f "Thursday, May 4th, 2006") + (test-string 'american #t "Thursday, May 4th, 2006 3:02:01am") + (test-string 'chinese #f "2006/5/4 星期四") + (test-string 'chinese #t "2006/5/4 星期四 03:02:01") + (test-string 'german #f "4. Mai 2006") + (test-string 'german #t "4. Mai 2006, 03.02") + (test-string 'indian #f "4-5-2006") + (test-string 'indian #t "4-5-2006 3:02:01am") + (test-string 'irish #f "Thursday, 4th May 2006") + (test-string 'irish #t "Thursday, 4th May 2006, 3:02am") + (test-string 'iso-8601 #f "2006-05-04") + (test-string 'iso-8601 #t "2006-05-04 03:02:01") + (test-string 'rfc2822 #f "Thu, 4 May 2006") + (test-string 'rfc2822 #t "Thu, 4 May 2006 03:02:01 -0600") + (test-string 'julian #f "JD 2 453 860") + (test-string 'julian #t "JD 2 453 860, 03:02:01") + + (test 2453860 date->julian/scalinger d) + (test "JD 2 453 860" julian/scalinger->string 2453860)) + ;; Bad dates (err/rt-test (find-seconds 0 0 0 0 0 1990) exn:fail?) (err/rt-test (find-seconds 0 0 0 0 1 1990) exn:fail?) From 581458f0be2d6adf04933b00515643c6e383087a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 13:25:14 -0600 Subject: [PATCH 28/31] Converting to racket and with contracts --- collects/mzlib/date.rkt | 716 +++++++++++++++++++--------------------- 1 file changed, 340 insertions(+), 376 deletions(-) diff --git a/collects/mzlib/date.rkt b/collects/mzlib/date.rkt index 7274248368..5c06ec570c 100644 --- a/collects/mzlib/date.rkt +++ b/collects/mzlib/date.rkt @@ -1,391 +1,355 @@ +#lang racket/base +(require racket/promise + racket/contract) -(module date mzscheme +(provide/contract + [date->string ((date?) (boolean?) . ->* . string?)] + [date-display-format (parameter/c (symbols 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))] + [find-seconds ((integer-in 0 61) + (integer-in 0 59) + (integer-in 0 23) + (integer-in 1 31) + (integer-in 1 12) + exact-nonnegative-integer? + . -> . + exact-integer?)] + [date->julian/scalinger (date? . -> . exact-integer?)] + [julian/scalinger->string (exact-integer? . -> . string?)]) - (require "list.rkt") +;; Support for Julian calendar added by Shriram; +;; current version only works until 2099 CE Gregorian - (provide date->string - date-display-format - find-seconds - - date->julian/scalinger - julian/scalinger->string) +(define date-display-format + (make-parameter 'american)) + +(define month/number->string + (lambda (x) + (case x + [(12) "December"] [(1) "January"] [(2) "February"] + [(3) "March"] [(4) "April"] [(5) "May"] + [(6) "June"] [(7) "July"] [(8) "August"] + [(9) "September"] [(10) "October"] [(11) "November"] + [else ""]))) + +(define day/number->string + (lambda (x) + (case x + [(0) "Sunday"] + [(1) "Monday"] + [(2) "Tuesday"] + [(3) "Wednesday"] + [(4) "Thursday"] + [(5) "Friday"] + [(6) "Saturday"] + [else ""]))) + +(define date->string + (case-lambda + [(date) (date->string date #f)] + [(date time?) + (let* ((add-zero (lambda (n) (if (< n 10) + (string-append "0" (number->string n)) + (number->string n)))) + (year (number->string (date-year date))) + (num-month (number->string (date-month date))) + (week-day (day/number->string (date-week-day date))) + (week-day-num (date-week-day date)) + (month (month/number->string (date-month date))) + (day (number->string (date-day date))) + (day-th (if (<= 11 (date-day date) 13) + "th" + (case (modulo (date-day date) 10) + [(1) "st"] + [(2) "nd"] + [(3) "rd"] + [(0 4 5 6 7 8 9) "th"]))) + (hour (date-hour date)) + (am-pm (if (>= hour 12) "pm" "am")) + (hour24 (add-zero hour)) + (hour12 (number->string + (cond + [(zero? hour) 12] + [(> hour 12) (- hour 12)] + [else hour]))) + (minute (add-zero (date-minute date))) + (second (add-zero (date-second date)))) + (let-values + ([(day time) + (case (date-display-format) + [(american) + (values (list week-day ", " month " " day day-th ", " year) + (list " " hour12 ":" minute ":" second am-pm))] + [(chinese) + (values + (list year "/" num-month "/" day + " \u661F\u671F" (case (date-week-day date) + [(0) "\u5929"] + [(1) "\u4E00"] + [(2) "\u4E8C"] + [(3) "\u4e09"] + [(4) "\u56DB"] + [(5) "\u4E94"] + [(6) "\u516D"] + [else ""])) + (list " " hour24 ":" minute ":" second))] + [(indian) + (values (list day "-" num-month "-" year) + (list " " hour12 ":" minute ":" second am-pm))] + [(german) + (values (list day ". " + (case (date-month date) + [(1) "Januar"] + [(2) "Februar"] + [(3) "M\344rz"] + [(4) "April"] + [(5) "Mai"] + [(6) "Juni"] + [(7) "Juli"] + [(8) "August"] + [(9) "September"] + [(10) "Oktober"] + [(11) "November"] + [(12) "Dezember"] + [else ""]) + " " year) + (list ", " hour24 "." minute))] + [(irish) + (values (list week-day ", " day day-th " " month " " year) + (list ", " hour12 ":" minute am-pm))] + [(julian) + (values (list (julian/scalinger->string + (date->julian/scalinger date))) + (list ", " hour24 ":" minute ":" second))] + [(iso-8601) + (values + (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date))) + (list " " hour24 ":" minute ":" second))] + [(rfc2822) + (values + (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year) + (list* " " hour24 ":" minute ":" second " " + (let* ([delta (date-time-zone-offset date)] + [hours (quotient delta 3600)] + [minutes (modulo (quotient delta 60) 60)]) + (list + (if (negative? delta) "-" "+") + (add-zero (abs hours)) + (add-zero minutes)))))] + [else (error 'date->string "unknown date-display-format: ~s" + (date-display-format))])]) + (apply string-append (if time? + (append day time) + day))))])) + +(define leap-year? + (lambda (year) + (or (= 0 (modulo year 400)) + (and (= 0 (modulo year 4)) + (not (= 0 (modulo year 100))))))) + +;; it's not clear what months mean in this context -- use days +(define-struct date-offset (second minute hour day year)) + +(define date- + (lambda (date1 date2) + (let* ((second (- (date-second date1) (date-second date2))) + (minute (+ (- (date-minute date1) (date-minute date2)) + (if (< second 0) -1 0))) + (hour (+ (- (date-hour date1) (date-hour date2)) + (if (< minute 0) -1 0) + (cond [(equal? (date-dst? date1) (date-dst? date2)) 0] + [(date-dst? date1) -1] + [(date-dst? date2) 1]))) + (day (+ (- (date-year-day date1) (date-year-day date2)) + (if (< hour 0) -1 0))) + (year (+ (- (date-year date1) (date-year date2)) + (if (< day 0) -1 0))) + (fixup (lambda (s x) (if (< s 0) (+ s x) s)))) + (make-date-offset (fixup second 60) + (fixup minute 60) + (fixup hour 24) + (fixup day (if (leap-year? (date-year date1)) 366 365)) + year)))) - ;; Support for Julian calendar added by Shriram; - ;; current version only works until 2099 CE Gregorian - - #| - - (define-primitive seconds->date (num -> structure:date)) - (define-primitive current-seconds (-> num)) - (define-primitive date-second (structure:date -> num)) - (define-primitive date-minute (structure:date -> num)) - (define-primitive date-hour (structure:date -> num)) - (define-primitive date-day (structure:date -> num)) - (define-primitive date-month (structure:date -> num)) - (define-primitive date-year (structure:date -> num)) - (define-primitive date-week-day (structure:date -> num)) - (define-primitive date-year-day (structure:date -> num)) - (define-primitive date-dst? (structure:date -> bool)) - (define-primitive make-date (num num num num num num num num bool -> - structure:date)) - (define-primitive expr->string (a -> string)) - (define-primitive foldl (case-> - ((a z -> z) z (listof a) -> z) - ((a b z -> z) z (listof a) (listof b) -> z) - ((a b c z -> z) z (listof a) (listof b) (listof c) -> z) - (((arglistof x) ->* z) z (listof (arglistof x)) ->* z))) - (define-primitive foldr (case-> - ((a z -> z) z (listof a) -> z) - ((a b z -> z) z (listof a) (listof b) -> z) - ((a b c z -> z) z (listof a) (listof b) (listof c) -> z) - (((arglistof x) ->* z) z (listof (arglistof x)) ->* z))) - - |# - - (define legal-formats - (list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822)) - - (define date-display-format - (make-parameter 'american - (lambda (s) - (unless (memq s legal-formats) - (raise-type-error 'date-display-format - (format "symbol in ~a" legal-formats) - s)) - s))) - - (define month/number->string - (lambda (x) - (case x - [(12) "December"] [(1) "January"] [(2) "February"] - [(3) "March"] [(4) "April"] [(5) "May"] - [(6) "June"] [(7) "July"] [(8) "August"] - [(9) "September"] [(10) "October"] [(11) "November"] - [else ""]))) - - (define day/number->string - (lambda (x) - (case x - [(0) "Sunday"] - [(1) "Monday"] - [(2) "Tuesday"] - [(3) "Wednesday"] - [(4) "Thursday"] - [(5) "Friday"] - [(6) "Saturday"] - [else ""]))) - - (define date->string +(define date-offset->string + (let ((first car) + (second cadr)) (case-lambda - [(date) (date->string date #f)] - [(date time?) - (let* ((add-zero (lambda (n) (if (< n 10) - (string-append "0" (number->string n)) - (number->string n)))) - (year (number->string (date-year date))) - (num-month (number->string (date-month date))) - (week-day (day/number->string (date-week-day date))) - (week-day-num (date-week-day date)) - (month (month/number->string (date-month date))) - (day (number->string (date-day date))) - (day-th (if (<= 11 (date-day date) 13) - "th" - (case (modulo (date-day date) 10) - [(1) "st"] - [(2) "nd"] - [(3) "rd"] - [(0 4 5 6 7 8 9) "th"]))) - (hour (date-hour date)) - (am-pm (if (>= hour 12) "pm" "am")) - (hour24 (add-zero hour)) - (hour12 (number->string - (cond - [(zero? hour) 12] - [(> hour 12) (- hour 12)] - [else hour]))) - (minute (add-zero (date-minute date))) - (second (add-zero (date-second date)))) - (let-values - ([(day time) - (case (date-display-format) - [(american) - (values (list week-day ", " month " " day day-th ", " year) - (list " " hour12 ":" minute ":" second am-pm))] - [(chinese) - (values - (list year "/" num-month "/" day - " \u661F\u671F" (case (date-week-day date) - [(0) "\u5929"] - [(1) "\u4E00"] - [(2) "\u4E8C"] - [(3) "\u4e09"] - [(4) "\u56DB"] - [(5) "\u4E94"] - [(6) "\u516D"] - [else ""])) - (list " " hour24 ":" minute ":" second))] - [(indian) - (values (list day "-" num-month "-" year) - (list " " hour12 ":" minute ":" second am-pm))] - [(german) - (values (list day ". " - (case (date-month date) - [(1) "Januar"] - [(2) "Februar"] - [(3) "M\344rz"] - [(4) "April"] - [(5) "Mai"] - [(6) "Juni"] - [(7) "Juli"] - [(8) "August"] - [(9) "September"] - [(10) "Oktober"] - [(11) "November"] - [(12) "Dezember"] - [else ""]) - " " year) - (list ", " hour24 "." minute))] - [(irish) - (values (list week-day ", " day day-th " " month " " year) - (list ", " hour12 ":" minute am-pm))] - [(julian) - (values (list (julian/scalinger->string - (date->julian/scalinger date))) - (list ", " hour24 ":" minute ":" second))] - [(iso-8601) - (values - (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date))) - (list " " hour24 ":" minute ":" second))] - [(rfc2822) - (values - (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year) - (list* " " hour24 ":" minute ":" second " " - (let* ([delta (date-time-zone-offset date)] - [hours (quotient delta 3600)] - [minutes (modulo (quotient delta 60) 60)]) - (list - (if (negative? delta) "-" "+") - (add-zero (abs hours)) - (add-zero minutes)))))] - [else (error 'date->string "unknown date-display-format: ~s" - (date-display-format))])]) - (apply string-append (if time? - (append day time) - day))))])) - - (define leap-year? - (lambda (year) - (or (= 0 (modulo year 400)) - (and (= 0 (modulo year 4)) - (not (= 0 (modulo year 100))))))) + [(date) (date-offset->string date #f)] + [(date seconds?) + (let* ((fields (list (list (date-offset-year date) "year") + (list (date-offset-day date) "day") + (list (date-offset-hour date) "hour") + (list (date-offset-minute date) "minute") + (list (if seconds? (date-offset-second date) 0) "second"))) + (non-zero-fields (foldl (lambda (x l) + (if (= 0 (first x)) + l + (cons x l))) + null + fields)) + (one-entry (lambda (b) + (string-append + (number->string (first b)) + " " + (second b) + (if (= 1 (first b)) "" "s"))))) + (cond + [(null? non-zero-fields) ""] + [(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))] + [else (foldl (lambda (b string) + (cond + [(= 0 (first b)) string] + [(string=? string "") + (string-append "and " + (one-entry b) + string)] + [else (string-append (one-entry b) ", " string)])) + "" + non-zero-fields)]))]))) - ;; it's not clear what months mean in this context -- use days - (define-struct date-offset (second minute hour day year)) +(define days-per-month + (lambda (year month) + (cond + [(and (= month 2) (leap-year? year)) 29] + [(= month 2) 28] + [(<= month 7) (+ 30 (modulo month 2))] + [else (+ 30 (- 1 (modulo month 2)))]))) - (define date- - (lambda (date1 date2) - (let* ((second (- (date-second date1) (date-second date2))) - (minute (+ (- (date-minute date1) (date-minute date2)) - (if (< second 0) -1 0))) - (hour (+ (- (date-hour date1) (date-hour date2)) - (if (< minute 0) -1 0) - (cond [(equal? (date-dst? date1) (date-dst? date2)) 0] - [(date-dst? date1) -1] - [(date-dst? date2) 1]))) - (day (+ (- (date-year-day date1) (date-year-day date2)) - (if (< hour 0) -1 0))) - (year (+ (- (date-year date1) (date-year date2)) - (if (< day 0) -1 0))) - (fixup (lambda (s x) (if (< s 0) (+ s x) s)))) - (make-date-offset (fixup second 60) - (fixup minute 60) - (fixup hour 24) - (fixup day (if (leap-year? (date-year date1)) 366 365)) - year)))) +(define find-extreme-date-seconds + (lambda (start offset) + (let/ec found + (letrec ([find-between + (lambda (lo hi) + (let ([mid (floor (/ (+ lo hi) 2))]) + (if (or (and (positive? offset) (= lo mid)) + (and (negative? offset) (= hi mid))) + (found lo) + (let ([mid-ok? + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (seconds->date mid) + #t)]) + (if mid-ok? + (find-between mid hi) + (find-between lo mid))))))]) + (let loop ([lo start][offset offset]) + (let ([hi (+ lo offset)]) + (with-handlers ([exn:fail? + (lambda (exn) + ; failed - must be between lo & hi + (find-between lo hi))]) + (seconds->date hi)) + ; succeeded; double offset again + (loop hi (* 2 offset)))))))) +(define get-min-seconds + (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))]) + (lambda () + (force d)))) +(define get-max-seconds + (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))]) + (lambda () + (force d)))) - (define date-offset->string - (let ((first car) - (second cadr)) - (case-lambda - [(date) (date-offset->string date #f)] - [(date seconds?) - (let* ((fields (list (list (date-offset-year date) "year") - (list (date-offset-day date) "day") - (list (date-offset-hour date) "hour") - (list (date-offset-minute date) "minute") - (list (if seconds? (date-offset-second date) 0) "second"))) - (non-zero-fields (foldl (lambda (x l) - (if (= 0 (first x)) - l - (cons x l))) - null - fields)) - (one-entry (lambda (b) - (string-append - (number->string (first b)) - " " - (second b) - (if (= 1 (first b)) "" "s"))))) - (cond - [(null? non-zero-fields) ""] - [(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))] - [else (foldl (lambda (b string) - (cond - [(= 0 (first b)) string] - [(string=? string "") - (string-append "and " - (one-entry b) - string)] - [else (string-append (one-entry b) ", " string)])) - "" - non-zero-fields)]))]))) +(define find-seconds + (lambda (sec min hour day month year) + (let ([signal-error + (lambda (msg) + (error 'find-secs (string-append + msg + " (inputs: ~a ~a ~a ~a ~a ~a)") + sec min hour day month year))]) + (let loop ([below-secs (get-min-seconds)] + [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] + [above-secs (get-max-seconds)]) + (let* ([date (seconds->date secs)] + [compare + (let loop ([inputs (list year month day + hour min sec)] + [tests (list (date-year date) + (date-month date) + (date-day date) + (date-hour date) + (date-minute date) + (date-second date))]) + (cond + [(null? inputs) 'equal] + [else (let ([input (car inputs)] + [test (car tests)]) + (if (= input test) + (loop (cdr inputs) (cdr tests)) + (if (<= input test) + 'input-smaller + 'test-smaller)))]))]) + ; (printf "~a ~a ~a~n" compare secs (date->string date)) + (cond + [(eq? compare 'equal) secs] + [(or (= secs below-secs) (= secs above-secs)) + (signal-error "non-existent date")] + [(eq? compare 'input-smaller) + (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)] + [(eq? compare 'test-smaller) + (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)])))))) - (define days-per-month - (lambda (year month) - (cond - [(and (= month 2) (leap-year? year)) 29] - [(= month 2) 28] - [(<= month 7) (+ 30 (modulo month 2))] - [else (+ 30 (- 1 (modulo month 2)))]))) +;; date->julian/scalinger : +;; date -> number [julian-day] - (define find-extreme-date-seconds - (lambda (start offset) - (let/ec found - (letrec ([find-between - (lambda (lo hi) - (let ([mid (floor (/ (+ lo hi) 2))]) - (if (or (and (positive? offset) (= lo mid)) - (and (negative? offset) (= hi mid))) - (found lo) - (let ([mid-ok? - (with-handlers ([exn:fail? (lambda (exn) #f)]) - (seconds->date mid) - #t)]) - (if mid-ok? - (find-between mid hi) - (find-between lo mid))))))]) - (let loop ([lo start][offset offset]) - (let ([hi (+ lo offset)]) - (with-handlers ([exn:fail? - (lambda (exn) - ; failed - must be between lo & hi - (find-between lo hi))]) - (seconds->date hi)) - ; succeeded; double offset again - (loop hi (* 2 offset)))))))) +;; Note: This code is correct until 2099 CE Gregorian - (define get-min-seconds - (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))]) - (lambda () - (force d)))) - (define get-max-seconds - (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))]) - (lambda () - (force d)))) +(define (date->julian/scalinger date) + (let ((day (date-day date)) + (month (date-month date)) + (year (date-year date))) + (let ((year (+ 4712 year))) + (let ((year (if (< month 3) (sub1 year) year))) + (let ((cycle-number (quotient year 4)) + (cycle-position (remainder year 4))) + (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))) + (let ((month-day-number (case month + ((3) 0) + ((4) 31) + ((5) 61) + ((6) 92) + ((7) 122) + ((8) 153) + ((9) 184) + ((10) 214) + ((11) 245) + ((12) 275) + ((1) 306) + ((2) 337)))) + (let ((total-days (+ base-day month-day-number day))) + (let ((total-days/march-adjustment (+ total-days 59))) + (let ((gregorian-adjustment (cond + ((< year 1700) 11) + ((< year 1800) 12) + (else 13)))) + (let ((final-date (- total-days/march-adjustment + gregorian-adjustment))) + final-date))))))))))) - (define find-seconds - (lambda (sec min hour day month year) - (let ([signal-error - (lambda (msg) - (error 'find-secs (string-append - msg - " (inputs: ~a ~a ~a ~a ~a ~a)") - sec min hour day month year))]) - (let loop ([below-secs (get-min-seconds)] - [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] - [above-secs (get-max-seconds)]) - (let* ([date (seconds->date secs)] - [compare - (let loop ([inputs (list year month day - hour min sec)] - [tests (list (date-year date) - (date-month date) - (date-day date) - (date-hour date) - (date-minute date) - (date-second date))]) - (cond - [(null? inputs) 'equal] - [else (let ([input (car inputs)] - [test (car tests)]) - (if (= input test) - (loop (cdr inputs) (cdr tests)) - (if (<= input test) - 'input-smaller - 'test-smaller)))]))]) - ; (printf "~a ~a ~a~n" compare secs (date->string date)) - (cond - [(eq? compare 'equal) secs] - [(or (= secs below-secs) (= secs above-secs)) - (signal-error "non-existent date")] - [(eq? compare 'input-smaller) - (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)] - [(eq? compare 'test-smaller) - (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)])))))) - - ;; date->julian/scalinger : - ;; date -> number [julian-day] - - ;; Note: This code is correct until 2099 CE Gregorian - - (define (date->julian/scalinger date) - (let ((day (date-day date)) - (month (date-month date)) - (year (date-year date))) - (let ((year (+ 4712 year))) - (let ((year (if (< month 3) (sub1 year) year))) - (let ((cycle-number (quotient year 4)) - (cycle-position (remainder year 4))) - (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))) - (let ((month-day-number (case month - ((3) 0) - ((4) 31) - ((5) 61) - ((6) 92) - ((7) 122) - ((8) 153) - ((9) 184) - ((10) 214) - ((11) 245) - ((12) 275) - ((1) 306) - ((2) 337)))) - (let ((total-days (+ base-day month-day-number day))) - (let ((total-days/march-adjustment (+ total-days 59))) - (let ((gregorian-adjustment (cond - ((< year 1700) 11) - ((< year 1800) 12) - (else 13)))) - (let ((final-date (- total-days/march-adjustment - gregorian-adjustment))) - final-date))))))))))) - - ;; julian/scalinger->string : - ;; number [julian-day] -> string [julian-day-format] - - (define (julian/scalinger->string julian-day) - (apply string-append - (cons "JD " - (reverse - (let loop ((reversed-digits (map number->string - (let loop ((jd julian-day)) - (if (zero? jd) null - (cons (remainder jd 10) - (loop (quotient jd 10)))))))) - (cond - ((or (null? reversed-digits) - (null? (cdr reversed-digits)) - (null? (cdr (cdr reversed-digits))) - (null? (cdr (cdr (cdr reversed-digits))))) - (list (apply string-append (reverse reversed-digits)))) - (else (cons (apply string-append - (list " " - (caddr reversed-digits) - (cadr reversed-digits) - (car reversed-digits))) - (loop (cdr (cdr (cdr reversed-digits)))))))))))) - - ) +;; julian/scalinger->string : +;; number [julian-day] -> string [julian-day-format] +(define (julian/scalinger->string julian-day) + (apply string-append + (cons "JD " + (reverse + (let loop ((reversed-digits (map number->string + (let loop ((jd julian-day)) + (if (zero? jd) null + (cons (remainder jd 10) + (loop (quotient jd 10)))))))) + (cond + ((or (null? reversed-digits) + (null? (cdr reversed-digits)) + (null? (cdr (cdr reversed-digits))) + (null? (cdr (cdr (cdr reversed-digits))))) + (list (apply string-append (reverse reversed-digits)))) + (else (cons (apply string-append + (list " " + (caddr reversed-digits) + (cadr reversed-digits) + (car reversed-digits))) + (loop (cdr (cdr (cdr reversed-digits)))))))))))) \ No newline at end of file From 991e2a4064b48402dc272f5cad40be50c560fd08 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 13:56:43 -0600 Subject: [PATCH 29/31] Using modern style a little --- collects/mzlib/date.rkt | 554 ++++++++++++++++++++-------------------- 1 file changed, 275 insertions(+), 279 deletions(-) diff --git a/collects/mzlib/date.rkt b/collects/mzlib/date.rkt index 5c06ec570c..973f220151 100644 --- a/collects/mzlib/date.rkt +++ b/collects/mzlib/date.rkt @@ -1,5 +1,8 @@ #lang racket/base (require racket/promise + racket/match + racket/list + racket/function racket/contract) (provide/contract @@ -22,226 +25,218 @@ (define date-display-format (make-parameter 'american)) -(define month/number->string - (lambda (x) - (case x - [(12) "December"] [(1) "January"] [(2) "February"] - [(3) "March"] [(4) "April"] [(5) "May"] - [(6) "June"] [(7) "July"] [(8) "August"] - [(9) "September"] [(10) "October"] [(11) "November"] - [else ""]))) +(define (month/number->string x) + (case x + [(12) "December"] [(1) "January"] [(2) "February"] + [(3) "March"] [(4) "April"] [(5) "May"] + [(6) "June"] [(7) "July"] [(8) "August"] + [(9) "September"] [(10) "October"] [(11) "November"] + [else ""])) -(define day/number->string - (lambda (x) - (case x - [(0) "Sunday"] - [(1) "Monday"] - [(2) "Tuesday"] - [(3) "Wednesday"] - [(4) "Thursday"] - [(5) "Friday"] - [(6) "Saturday"] - [else ""]))) +(define (day/number->string x) + (case x + [(0) "Sunday"] + [(1) "Monday"] + [(2) "Tuesday"] + [(3) "Wednesday"] + [(4) "Thursday"] + [(5) "Friday"] + [(6) "Saturday"] + [else ""])) -(define date->string - (case-lambda - [(date) (date->string date #f)] - [(date time?) - (let* ((add-zero (lambda (n) (if (< n 10) - (string-append "0" (number->string n)) - (number->string n)))) - (year (number->string (date-year date))) - (num-month (number->string (date-month date))) - (week-day (day/number->string (date-week-day date))) - (week-day-num (date-week-day date)) - (month (month/number->string (date-month date))) - (day (number->string (date-day date))) - (day-th (if (<= 11 (date-day date) 13) - "th" - (case (modulo (date-day date) 10) - [(1) "st"] - [(2) "nd"] - [(3) "rd"] - [(0 4 5 6 7 8 9) "th"]))) - (hour (date-hour date)) - (am-pm (if (>= hour 12) "pm" "am")) - (hour24 (add-zero hour)) - (hour12 (number->string - (cond - [(zero? hour) 12] - [(> hour 12) (- hour 12)] - [else hour]))) - (minute (add-zero (date-minute date))) - (second (add-zero (date-second date)))) - (let-values - ([(day time) - (case (date-display-format) - [(american) - (values (list week-day ", " month " " day day-th ", " year) - (list " " hour12 ":" minute ":" second am-pm))] - [(chinese) - (values - (list year "/" num-month "/" day - " \u661F\u671F" (case (date-week-day date) - [(0) "\u5929"] - [(1) "\u4E00"] - [(2) "\u4E8C"] - [(3) "\u4e09"] - [(4) "\u56DB"] - [(5) "\u4E94"] - [(6) "\u516D"] - [else ""])) - (list " " hour24 ":" minute ":" second))] - [(indian) - (values (list day "-" num-month "-" year) - (list " " hour12 ":" minute ":" second am-pm))] - [(german) - (values (list day ". " - (case (date-month date) - [(1) "Januar"] - [(2) "Februar"] - [(3) "M\344rz"] - [(4) "April"] - [(5) "Mai"] - [(6) "Juni"] - [(7) "Juli"] - [(8) "August"] - [(9) "September"] - [(10) "Oktober"] - [(11) "November"] - [(12) "Dezember"] - [else ""]) - " " year) - (list ", " hour24 "." minute))] - [(irish) - (values (list week-day ", " day day-th " " month " " year) - (list ", " hour12 ":" minute am-pm))] - [(julian) - (values (list (julian/scalinger->string - (date->julian/scalinger date))) - (list ", " hour24 ":" minute ":" second))] - [(iso-8601) - (values - (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date))) - (list " " hour24 ":" minute ":" second))] - [(rfc2822) - (values - (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year) - (list* " " hour24 ":" minute ":" second " " - (let* ([delta (date-time-zone-offset date)] - [hours (quotient delta 3600)] - [minutes (modulo (quotient delta 60) 60)]) - (list - (if (negative? delta) "-" "+") - (add-zero (abs hours)) - (add-zero minutes)))))] - [else (error 'date->string "unknown date-display-format: ~s" - (date-display-format))])]) - (apply string-append (if time? - (append day time) - day))))])) +(define (add-zero n) + (if (< n 10) + (string-append "0" (number->string n)) + (number->string n))) -(define leap-year? - (lambda (year) - (or (= 0 (modulo year 400)) - (and (= 0 (modulo year 4)) - (not (= 0 (modulo year 100))))))) +(define (date->string date [time? #f]) + (define year (number->string (date-year date))) + (define num-month (number->string (date-month date))) + (define week-day (day/number->string (date-week-day date))) + (define week-day-num (date-week-day date)) + (define month (month/number->string (date-month date))) + (define day (number->string (date-day date))) + (define day-th + (if (<= 11 (date-day date) 13) + "th" + (case (modulo (date-day date) 10) + [(1) "st"] + [(2) "nd"] + [(3) "rd"] + [(0 4 5 6 7 8 9) "th"]))) + (define hour (date-hour date)) + (define am-pm (if (>= hour 12) "pm" "am")) + (define hour24 (add-zero hour)) + (define hour12 + (number->string + (cond + [(zero? hour) 12] + [(> hour 12) (- hour 12)] + [else hour]))) + (define minute (add-zero (date-minute date))) + (define second (add-zero (date-second date))) + (define-values + (day-strs time-strs) + (case (date-display-format) + [(american) + (values (list week-day ", " month " " day day-th ", " year) + (list " " hour12 ":" minute ":" second am-pm))] + [(chinese) + (values + (list year "/" num-month "/" day + " \u661F\u671F" (case (date-week-day date) + [(0) "\u5929"] + [(1) "\u4E00"] + [(2) "\u4E8C"] + [(3) "\u4e09"] + [(4) "\u56DB"] + [(5) "\u4E94"] + [(6) "\u516D"] + [else ""])) + (list " " hour24 ":" minute ":" second))] + [(indian) + (values (list day "-" num-month "-" year) + (list " " hour12 ":" minute ":" second am-pm))] + [(german) + (values (list day ". " + (case (date-month date) + [(1) "Januar"] + [(2) "Februar"] + [(3) "M\344rz"] + [(4) "April"] + [(5) "Mai"] + [(6) "Juni"] + [(7) "Juli"] + [(8) "August"] + [(9) "September"] + [(10) "Oktober"] + [(11) "November"] + [(12) "Dezember"] + [else ""]) + " " year) + (list ", " hour24 "." minute))] + [(irish) + (values (list week-day ", " day day-th " " month " " year) + (list ", " hour12 ":" minute am-pm))] + [(julian) + (values (list (julian/scalinger->string + (date->julian/scalinger date))) + (list ", " hour24 ":" minute ":" second))] + [(iso-8601) + (values + (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date))) + (list " " hour24 ":" minute ":" second))] + [(rfc2822) + (values + (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year) + (list* " " hour24 ":" minute ":" second " " + (let* ([delta (date-time-zone-offset date)] + [hours (quotient delta 3600)] + [minutes (modulo (quotient delta 60) 60)]) + (list + (if (negative? delta) "-" "+") + (add-zero (abs hours)) + (add-zero minutes)))))] + [else (error 'date->string "unknown date-display-format: ~s" + (date-display-format))])) + (apply string-append + (if time? + (append day-strs time-strs) + day-strs))) + +(define (leap-year? year) + (or (= 0 (modulo year 400)) + (and (= 0 (modulo year 4)) + (not (= 0 (modulo year 100)))))) ;; it's not clear what months mean in this context -- use days (define-struct date-offset (second minute hour day year)) -(define date- - (lambda (date1 date2) - (let* ((second (- (date-second date1) (date-second date2))) - (minute (+ (- (date-minute date1) (date-minute date2)) - (if (< second 0) -1 0))) - (hour (+ (- (date-hour date1) (date-hour date2)) - (if (< minute 0) -1 0) - (cond [(equal? (date-dst? date1) (date-dst? date2)) 0] - [(date-dst? date1) -1] - [(date-dst? date2) 1]))) - (day (+ (- (date-year-day date1) (date-year-day date2)) - (if (< hour 0) -1 0))) - (year (+ (- (date-year date1) (date-year date2)) - (if (< day 0) -1 0))) - (fixup (lambda (s x) (if (< s 0) (+ s x) s)))) - (make-date-offset (fixup second 60) - (fixup minute 60) - (fixup hour 24) - (fixup day (if (leap-year? (date-year date1)) 366 365)) - year)))) +(define (fixup s x) (if (< s 0) (+ s x) s)) +(define (date- date1 date2) + (define second (- (date-second date1) (date-second date2))) + (define minute + (+ (- (date-minute date1) (date-minute date2)) + (if (< second 0) -1 0))) + (define hour + (+ (- (date-hour date1) (date-hour date2)) + (if (< minute 0) -1 0) + (cond [(equal? (date-dst? date1) (date-dst? date2)) 0] + [(date-dst? date1) -1] + [(date-dst? date2) 1]))) + (define day + (+ (- (date-year-day date1) (date-year-day date2)) + (if (< hour 0) -1 0))) + (define year + (+ (- (date-year date1) (date-year date2)) + (if (< day 0) -1 0))) + (make-date-offset + (fixup second 60) + (fixup minute 60) + (fixup hour 24) + (fixup day (if (leap-year? (date-year date1)) 366 365)) + year)) +(define (one-entry b) + (string-append + (number->string (first b)) + " " + (second b) + (if (= 1 (first b)) "" "s"))) +(define (date-offset->string date [seconds? #f]) + (define fields + (list (list (date-offset-year date) "year") + (list (date-offset-day date) "day") + (list (date-offset-hour date) "hour") + (list (date-offset-minute date) "minute") + (list (if seconds? (date-offset-second date) 0) "second"))) + (define non-zero-fields + (filter (negate (compose (curry = 0) first)) fields)) + (match non-zero-fields + [(list) ""] + [(list one) (one-entry one)] + [_ + (for/fold ([string ""]) + ([b (in-list non-zero-fields)]) + (cond + [(= 0 (first b)) string] + [(string=? string "") + (string-append "and " + (one-entry b) + string)] + [else (string-append (one-entry b) ", " string)]))])) -(define date-offset->string - (let ((first car) - (second cadr)) - (case-lambda - [(date) (date-offset->string date #f)] - [(date seconds?) - (let* ((fields (list (list (date-offset-year date) "year") - (list (date-offset-day date) "day") - (list (date-offset-hour date) "hour") - (list (date-offset-minute date) "minute") - (list (if seconds? (date-offset-second date) 0) "second"))) - (non-zero-fields (foldl (lambda (x l) - (if (= 0 (first x)) - l - (cons x l))) - null - fields)) - (one-entry (lambda (b) - (string-append - (number->string (first b)) - " " - (second b) - (if (= 1 (first b)) "" "s"))))) - (cond - [(null? non-zero-fields) ""] - [(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))] - [else (foldl (lambda (b string) - (cond - [(= 0 (first b)) string] - [(string=? string "") - (string-append "and " - (one-entry b) - string)] - [else (string-append (one-entry b) ", " string)])) - "" - non-zero-fields)]))]))) +(define (days-per-month year month) + (cond + [(and (= month 2) (leap-year? year)) 29] + [(= month 2) 28] + [(<= month 7) (+ 30 (modulo month 2))] + [else (+ 30 (- 1 (modulo month 2)))])) -(define days-per-month - (lambda (year month) - (cond - [(and (= month 2) (leap-year? year)) 29] - [(= month 2) 28] - [(<= month 7) (+ 30 (modulo month 2))] - [else (+ 30 (- 1 (modulo month 2)))]))) - -(define find-extreme-date-seconds - (lambda (start offset) - (let/ec found - (letrec ([find-between - (lambda (lo hi) - (let ([mid (floor (/ (+ lo hi) 2))]) - (if (or (and (positive? offset) (= lo mid)) - (and (negative? offset) (= hi mid))) - (found lo) - (let ([mid-ok? - (with-handlers ([exn:fail? (lambda (exn) #f)]) - (seconds->date mid) - #t)]) - (if mid-ok? - (find-between mid hi) - (find-between lo mid))))))]) - (let loop ([lo start][offset offset]) - (let ([hi (+ lo offset)]) - (with-handlers ([exn:fail? - (lambda (exn) - ; failed - must be between lo & hi - (find-between lo hi))]) - (seconds->date hi)) - ; succeeded; double offset again - (loop hi (* 2 offset)))))))) +(define (find-extreme-date-seconds start offset) + (let/ec found + (letrec ([find-between + (lambda (lo hi) + (let ([mid (floor (/ (+ lo hi) 2))]) + (if (or (and (positive? offset) (= lo mid)) + (and (negative? offset) (= hi mid))) + (found lo) + (let ([mid-ok? + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (seconds->date mid) + #t)]) + (if mid-ok? + (find-between mid hi) + (find-between lo mid))))))]) + (let loop ([lo start][offset offset]) + (let ([hi (+ lo offset)]) + (with-handlers ([exn:fail? + (lambda (exn) + ; failed - must be between lo & hi + (find-between lo hi))]) + (seconds->date hi)) + ; succeeded; double offset again + (loop hi (* 2 offset))))))) (define get-min-seconds (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))]) @@ -252,45 +247,43 @@ (lambda () (force d)))) -(define find-seconds - (lambda (sec min hour day month year) - (let ([signal-error - (lambda (msg) - (error 'find-secs (string-append - msg - " (inputs: ~a ~a ~a ~a ~a ~a)") - sec min hour day month year))]) - (let loop ([below-secs (get-min-seconds)] - [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] - [above-secs (get-max-seconds)]) - (let* ([date (seconds->date secs)] - [compare - (let loop ([inputs (list year month day - hour min sec)] - [tests (list (date-year date) - (date-month date) - (date-day date) - (date-hour date) - (date-minute date) - (date-second date))]) - (cond - [(null? inputs) 'equal] - [else (let ([input (car inputs)] - [test (car tests)]) - (if (= input test) - (loop (cdr inputs) (cdr tests)) - (if (<= input test) - 'input-smaller - 'test-smaller)))]))]) - ; (printf "~a ~a ~a~n" compare secs (date->string date)) - (cond - [(eq? compare 'equal) secs] - [(or (= secs below-secs) (= secs above-secs)) - (signal-error "non-existent date")] - [(eq? compare 'input-smaller) - (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)] - [(eq? compare 'test-smaller) - (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)])))))) +(define (find-seconds sec min hour day month year) + (define (signal-error msg) + (error 'find-secs (string-append + msg + " (inputs: ~a ~a ~a ~a ~a ~a)") + sec min hour day month year)) + (let loop ([below-secs (get-min-seconds)] + [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] + [above-secs (get-max-seconds)]) + (let* ([date (seconds->date secs)] + [compare + (let loop ([inputs (list year month day + hour min sec)] + [tests (list (date-year date) + (date-month date) + (date-day date) + (date-hour date) + (date-minute date) + (date-second date))]) + (cond + [(null? inputs) 'equal] + [else (let ([input (car inputs)] + [test (car tests)]) + (if (= input test) + (loop (cdr inputs) (cdr tests)) + (if (<= input test) + 'input-smaller + 'test-smaller)))]))]) + ; (printf "~a ~a ~a~n" compare secs (date->string date)) + (cond + [(eq? compare 'equal) secs] + [(or (= secs below-secs) (= secs above-secs)) + (signal-error "non-existent date")] + [(eq? compare 'input-smaller) + (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)] + [(eq? compare 'test-smaller) + (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)])))) ;; date->julian/scalinger : ;; date -> number [julian-day] @@ -298,36 +291,39 @@ ;; Note: This code is correct until 2099 CE Gregorian (define (date->julian/scalinger date) - (let ((day (date-day date)) - (month (date-month date)) - (year (date-year date))) - (let ((year (+ 4712 year))) - (let ((year (if (< month 3) (sub1 year) year))) - (let ((cycle-number (quotient year 4)) - (cycle-position (remainder year 4))) - (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))) - (let ((month-day-number (case month - ((3) 0) - ((4) 31) - ((5) 61) - ((6) 92) - ((7) 122) - ((8) 153) - ((9) 184) - ((10) 214) - ((11) 245) - ((12) 275) - ((1) 306) - ((2) 337)))) - (let ((total-days (+ base-day month-day-number day))) - (let ((total-days/march-adjustment (+ total-days 59))) - (let ((gregorian-adjustment (cond - ((< year 1700) 11) - ((< year 1800) 12) - (else 13)))) - (let ((final-date (- total-days/march-adjustment - gregorian-adjustment))) - final-date))))))))))) + (define day (date-day date)) + (define month (date-month date)) + (define d-year (date-year date)) + (define year (+ 4712 d-year)) + (define adj-year (if (< month 3) (sub1 year) year)) + (define cycle-number (quotient adj-year 4)) + (define cycle-position (remainder adj-year 4)) + (define base-day (+ (* 1461 cycle-number) (* 365 cycle-position))) + (define month-day-number + (case month + ((3) 0) + ((4) 31) + ((5) 61) + ((6) 92) + ((7) 122) + ((8) 153) + ((9) 184) + ((10) 214) + ((11) 245) + ((12) 275) + ((1) 306) + ((2) 337))) + (define total-days (+ base-day month-day-number day)) + (define total-days/march-adjustment (+ total-days 59)) + (define gregorian-adjustment + (cond + ((< adj-year 1700) 11) + ((< adj-year 1800) 12) + (else 13))) + (define final-date + (- total-days/march-adjustment + gregorian-adjustment)) + final-date) ;; julian/scalinger->string : ;; number [julian-day] -> string [julian-day-format] From 009ae0588ecb4387b73dfe6d807c7b5a4e27e243 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 14:00:08 -0600 Subject: [PATCH 30/31] Adding current-date --- collects/mzlib/date.rkt | 4 ++++ collects/scribblings/reference/time.scrbl | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/collects/mzlib/date.rkt b/collects/mzlib/date.rkt index 973f220151..597815e190 100644 --- a/collects/mzlib/date.rkt +++ b/collects/mzlib/date.rkt @@ -6,6 +6,7 @@ racket/contract) (provide/contract + [current-date (-> date?)] [date->string ((date?) (boolean?) . ->* . string?)] [date-display-format (parameter/c (symbols 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))] [find-seconds ((integer-in 0 61) @@ -19,6 +20,9 @@ [date->julian/scalinger (date? . -> . exact-integer?)] [julian/scalinger->string (exact-integer? . -> . string?)]) +(define (current-date) + (seconds->date (current-seconds))) + ;; Support for Julian calendar added by Shriram; ;; current version only works until 2099 CE Gregorian diff --git a/collects/scribblings/reference/time.scrbl b/collects/scribblings/reference/time.scrbl index 9a487a1523..dd9b7b9905 100644 --- a/collects/scribblings/reference/time.scrbl +++ b/collects/scribblings/reference/time.scrbl @@ -125,6 +125,10 @@ result is the result of @racket[expr].} @note-lib-only[racket/date] +@defproc[(current-date) date?]{ + +An abbreviation for @racket[(seconds->date (current-seconds))].} + @defproc[(date->string [date date?] [time? any/c #f]) string?]{ Converts a date to a string. The returned string contains the time of From 1b6b721aee3bd26c9fcb2cf985815f584e2b20a0 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 14:23:07 -0600 Subject: [PATCH 31/31] Adding date->seconds --- collects/mzlib/date.rkt | 10 ++++++++++ collects/scribblings/reference/time.scrbl | 5 ++++- collects/tests/racket/date.rktl | 5 ++++- 3 files changed, 18 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/date.rkt b/collects/mzlib/date.rkt index 597815e190..4767898f09 100644 --- a/collects/mzlib/date.rkt +++ b/collects/mzlib/date.rkt @@ -7,6 +7,7 @@ (provide/contract [current-date (-> date?)] + [date->seconds (date? . -> . exact-integer?)] [date->string ((date?) (boolean?) . ->* . string?)] [date-display-format (parameter/c (symbols 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))] [find-seconds ((integer-in 0 61) @@ -251,6 +252,15 @@ (lambda () (force d)))) +(define (date->seconds date) + (find-seconds + (date-second date) + (date-minute date) + (date-hour date) + (date-day date) + (date-month date) + (date-year date))) + (define (find-seconds sec min hour day month year) (define (signal-error msg) (error 'find-secs (string-append diff --git a/collects/scribblings/reference/time.scrbl b/collects/scribblings/reference/time.scrbl index dd9b7b9905..4a405ca46a 100644 --- a/collects/scribblings/reference/time.scrbl +++ b/collects/scribblings/reference/time.scrbl @@ -15,7 +15,6 @@ The value of @racket[(current-seconds)] increases as time passes seconds can be compared with a time returned by @racket[file-or-directory-modify-seconds].} - @defproc[(seconds->date [secs-n exact-integer?]) date?]{ Takes @racket[secs-n], a platform-specific time in seconds returned by @@ -147,6 +146,10 @@ day only if @racket[time?]. See also @racket[date-display-format].} Parameter that determines the date string format. The initial format is @racket['american].} +@defproc[(date->seconds [date date?]) exact-integer?]{ +Finds the representation of a date in platform-specific seconds. If +the platform cannot represent the specified date, an error is +signaled, otherwise an integer is returned. } @defproc[(find-seconds [second (integer-in 0 61)] [minute (integer-in 0 59)] diff --git a/collects/tests/racket/date.rktl b/collects/tests/racket/date.rktl index 074d38f5a3..5c1e368a2a 100644 --- a/collects/tests/racket/date.rktl +++ b/collects/tests/racket/date.rktl @@ -20,11 +20,14 @@ (test-find 0 0 0 1 4 2005) ; date->string -(let ([d (seconds->date (find-seconds 1 2 3 4 5 2006))]) +(let* ([secs (find-seconds 1 2 3 4 5 2006)] + [d (seconds->date secs)]) (define (test-string fmt time? result) (test (parameterize ([date-display-format fmt]) (date->string d time?)) fmt result)) + (test secs date->seconds d) + (test-string 'american #f "Thursday, May 4th, 2006") (test-string 'american #t "Thursday, May 4th, 2006 3:02:01am") (test-string 'chinese #f "2006/5/4 星期四")