From b23449ef000b2cfbc38785578ccbda3ce25c0bfb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 13 May 2009 07:50:18 +0000 Subject: [PATCH 01/39] Welcome to a new PLT day. svn: r14793 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 923a5855e3..f4127008df 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "12may2009") +#lang scheme/base (provide stamp) (define stamp "13may2009") From 09502205e211b1aa4c0d011f30717c359d02a281 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 05:47:18 +0000 Subject: [PATCH 02/39] typo in comment svn: r14800 --- collects/profile/analyzer.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/profile/analyzer.ss b/collects/profile/analyzer.ss index c080f4f01a..22bec08bf8 100644 --- a/collects/profile/analyzer.ss +++ b/collects/profile/analyzer.ss @@ -41,7 +41,7 @@ (lambda (node o w?) (fprintf o "#" (or (node-id node) '???)))) ;; An edge representing function calls between two nodes: -;; - time: the total time spent while the call was somewhere on the stack. +;; - total: the total time spent while the call was anywhere on the stack. ;; - caller, callee: the two relevant `node' values. ;; - caller-time, callee-time: the time that the caller/callee spent in this ;; call (different from the above time because each stack sample's time is From 975b4d2fa84b080e74218127022cef3b53c88184 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 05:49:15 +0000 Subject: [PATCH 03/39] use hash-ref! svn: r14801 --- collects/profile/analyzer.ss | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/collects/profile/analyzer.ss b/collects/profile/analyzer.ss index 22bec08bf8..5e5f651007 100644 --- a/collects/profile/analyzer.ss +++ b/collects/profile/analyzer.ss @@ -55,13 +55,8 @@ (or (node-id (edge-caller edge)) '???) (or (node-id (edge-callee edge)) '???)))) -(define with-hash:not-found (gensym)) (define-syntax-rule (with-hash ) - (let ([t ] [k ]) - (let ([v (hash-ref t k with-hash:not-found)]) - (if (eq? v with-hash:not-found) - (let ([v ]) (hash-set! t k v) v) - v)))) + (hash-ref! (lambda () ))) ;; This function analyzes the output of the sampler. Returns a `profile' ;; struct holding a list of `node' values, each one representing a node in the From 133f044a3380414b53d374770a4fd88445a2f270 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 07:23:09 +0000 Subject: [PATCH 04/39] finally, make the topological-sort do a topological sort instead of a BFS svn: r14802 --- collects/profile/analyzer.ss | 59 ++++++++++++++++++++++++++---------- 1 file changed, 43 insertions(+), 16 deletions(-) diff --git a/collects/profile/analyzer.ss b/collects/profile/analyzer.ss index 5e5f651007..8cbf57e867 100644 --- a/collects/profile/analyzer.ss +++ b/collects/profile/analyzer.ss @@ -144,30 +144,57 @@ nodes *-node))) -;; A simple topological sort of nodes using BFS, starting from node `x' which -;; will be the special *-node. `subsort' is a `resolver' function to sort -;; nodes on the same level. +;; A simple topological sort of nodes using BFS, starting from node `x' (which +;; will be given as the special *-node). `subsort' is a `resolver' function to +;; sort nodes on the same level. (define (topological-sort x subsort) - (let loop ([todo (list x)] [seen (list x)]) + (let loop ([todo (list x)] [sorted (list x)]) (if (null? todo) - '() - (let* ([next (append-map (lambda (x) - (subsort (map edge-callee (node-callees x)))) + (reverse sorted) + (let* (;; take the next level of nodes + [next (append-map (lambda (x) (map edge-callee (node-callees x))) todo)] - [next (remq* seen (remove-duplicates next))]) - (append todo (loop next (append next seen))))))) + ;; remove visited and duplicates + [next (remove-duplicates (remq* sorted next))] + ;; leave only nodes with no other incoming edges + [next* (filter (lambda (node) + (andmap (lambda (e) (memq (edge-caller e) sorted)) + (node-callers node))) + next)] + ;; but if all nodes have other incoming edges, then there must be + ;; a cycle, so just do them now (instead of dropping them) + [next (if (and (null? next*) (pair? next)) next next*)] + ;; sort using subsort + [next (subsort next)]) + (loop next (append (reverse next) sorted)))))) #| -(define (node id) (make-node id #f '() 0 0 '() '())) +(define-syntax-rule (letnodes [id ...] body ...) + (let ([id (make-node 'id #f '() 0 0 '() '())] ...) body ...)) (define (X . -> . Y) (let ([e (make-edge 0 X 0 Y 0)]) (set-node-callers! Y (cons e (node-callers Y))) (set-node-callees! X (cons e (node-callees X))))) -(define A (node 'A)) -(define B (node 'B)) -(define C (node 'C)) -(A . -> . B) -(B . -> . C) -(topological-sort A 3) +(letnodes [A B C] + (A . -> . B) + (B . -> . C) + (equal? (topological-sort A values) + (list A B C))) +(letnodes [A B C] + ;; check that a cycle doesn't lead to dropping nodes + (A . -> . B) + (A . -> . C) + (B . -> . A) + (B . -> . C) + (C . -> . A) + (C . -> . B) + (null? (remq* (topological-sort A values) (list A B C)))) +(letnodes [A B C D] + (A . -> . B) + (B . -> . C) + (C . -> . D) + (A . -> . D) + (equal? (topological-sort A values) + (list A B C D))) |# ;; Groups raw samples by their thread-id, returns a vector with a field for From 8bea8abc75d319e72a0c95da5b0bdfacff57486e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 07:31:36 +0000 Subject: [PATCH 05/39] * Factor out the struct definitions into a separate file * Move the topological sort into utils.ss svn: r14803 --- collects/profile/analyzer.ss | 51 +--------------------------- collects/profile/main.ss | 2 +- collects/profile/render-graphviz.ss | 2 +- collects/profile/render-text.ss | 2 +- collects/profile/structs.ss | 52 +++++++++++++++++++++++++++++ collects/profile/utils.ss | 2 +- 6 files changed, 57 insertions(+), 54 deletions(-) create mode 100644 collects/profile/structs.ss diff --git a/collects/profile/analyzer.ss b/collects/profile/analyzer.ss index 8cbf57e867..f3c765b19c 100644 --- a/collects/profile/analyzer.ss +++ b/collects/profile/analyzer.ss @@ -4,56 +4,7 @@ (provide analyze-samples) -(require scheme/list) - -;; An encapsulation of an analyzed profile call graph: -;; - total-time: the total time observed in msec (this is generally different -;; than the time it took to run the profile). -;; - sample-number: the number of samples taken. -;; - thread-times: a list of ( . msec) for the time spent in -;; observed threads. -;; - nodes: the list of call-graph nodes sorted by their total time. -;; - *-node: a special node that is connected as a "caller" for all toplevel -;; functions and a "callee" for all leaf functions. It will also be -;; identifiable by having both id and src fields being #f. Can be used to -;; start a graph traversal from the top or the bottom. -(provide (struct-out profile)) -(define-struct profile - (total-time cpu-time sample-number thread-times nodes *-node)) - -;; An entry for a single profiled function: -;; - id, src: the corresponding values from `continuation-mark-set->context'. -;; - thread-ids: the list of thread identifiers this function has been seen in. -;; - total: total msecs it participated in (= time in it, including callees). -;; - self: msecs where it was at the top of the stack (= time in its own code). -;; - callers, callees: a list of `edge' values for the time spent while it was -;; called by the repective , or it called it, sorted in decreasing msec -;; time. -;; Note that the sum of caller/callee edges including the special `*-node' -;; should be equal to the `total' time. So the edge from/to the `*-node' can -;; be used to get the time spent as a leaf or as a root divided by the number -;; of time the function appeared on the stack: so this value can be displayed -;; in the call-graph and the numbers will sum up nicely to a 100%. -(provide (struct-out node)) -(define-struct node (id src thread-ids total self callers callees) - #:mutable - #:property prop:custom-write - (lambda (node o w?) (fprintf o "#" (or (node-id node) '???)))) - -;; An edge representing function calls between two nodes: -;; - total: the total time spent while the call was anywhere on the stack. -;; - caller, callee: the two relevant `node' values. -;; - caller-time, callee-time: the time that the caller/callee spent in this -;; call (different from the above time because each stack sample's time is -;; divided by the number of times the caller/callee appears in that slice). -(provide (struct-out edge)) -(define-struct edge (total caller caller-time callee callee-time) - #:mutable - #:property prop:custom-write - (lambda (edge o w?) - (fprintf o "#" - (or (node-id (edge-caller edge)) '???) - (or (node-id (edge-callee edge)) '???)))) +(require scheme/list "structs.ss" "utils.ss") (define-syntax-rule (with-hash ) (hash-ref! (lambda () ))) diff --git a/collects/profile/main.ss b/collects/profile/main.ss index 2d990be39a..3c29bf0b3d 100644 --- a/collects/profile/main.ss +++ b/collects/profile/main.ss @@ -2,7 +2,7 @@ (provide profile-thunk profile) -(require "sampler.ss" (except-in "analyzer.ss" profile) +(require "sampler.ss" "analyzer.ss" (prefix-in text: "render-text.ss") (for-syntax scheme/base)) diff --git a/collects/profile/render-graphviz.ss b/collects/profile/render-graphviz.ss index 2c6e5c8e24..946a15f0d9 100644 --- a/collects/profile/render-graphviz.ss +++ b/collects/profile/render-graphviz.ss @@ -2,7 +2,7 @@ (provide render) -(require "analyzer.ss" "utils.ss") +(require "structs.ss" "analyzer.ss" "utils.ss") (define (render profile #:hide-self [hide-self% 1/100] diff --git a/collects/profile/render-text.ss b/collects/profile/render-text.ss index 60dcec01d7..8cda73accb 100644 --- a/collects/profile/render-text.ss +++ b/collects/profile/render-text.ss @@ -2,7 +2,7 @@ (provide render) -(require "analyzer.ss" "utils.ss" scheme/list) +(require "structs.ss" "analyzer.ss" "utils.ss" scheme/list) (define (f:msec msec) (number->string (round (inexact->exact msec)))) diff --git a/collects/profile/structs.ss b/collects/profile/structs.ss new file mode 100644 index 0000000000..6512b1f2d3 --- /dev/null +++ b/collects/profile/structs.ss @@ -0,0 +1,52 @@ +#lang scheme/base + +;; Struct definitions for the profiler + +;; An encapsulation of an analyzed profile call graph: +;; - total-time: the total time observed in msec (this is generally different +;; than the time it took to run the profile). +;; - sample-number: the number of samples taken. +;; - thread-times: a list of ( . msec) for the time spent in +;; observed threads. +;; - nodes: the list of call-graph nodes sorted by their total time. +;; - *-node: a special node that is connected as a "caller" for all toplevel +;; functions and a "callee" for all leaf functions. It will also be +;; identifiable by having both id and src fields being #f. Can be used to +;; start a graph traversal from the top or the bottom. +(provide (struct-out profile)) +(define-struct profile + (total-time cpu-time sample-number thread-times nodes *-node)) + +;; An entry for a single profiled function: +;; - id, src: the corresponding values from `continuation-mark-set->context'. +;; - thread-ids: the list of thread identifiers this function has been seen in. +;; - total: total msecs it participated in (= time in it, including callees). +;; - self: msecs where it was at the top of the stack (= time in its own code). +;; - callers, callees: a list of `edge' values for the time spent while it was +;; called by the repective , or it called it, sorted in decreasing msec +;; time. +;; Note that the sum of caller/callee edges including the special `*-node' +;; should be equal to the `total' time. So the edge from/to the `*-node' can +;; be used to get the time spent as a leaf or as a root divided by the number +;; of time the function appeared on the stack: so this value can be displayed +;; in the call-graph and the numbers will sum up nicely to a 100%. +(provide (struct-out node)) +(define-struct node (id src thread-ids total self callers callees) + #:mutable + #:property prop:custom-write + (lambda (node o w?) (fprintf o "#" (or (node-id node) '???)))) + +;; An edge representing function calls between two nodes: +;; - total: the total time spent while the call was anywhere on the stack. +;; - caller, callee: the two relevant `node' values. +;; - caller-time, callee-time: the time that the caller/callee spent in this +;; call (different from the above time because each stack sample's time is +;; divided by the number of times the caller/callee appears in that slice). +(provide (struct-out edge)) +(define-struct edge (total caller caller-time callee callee-time) + #:mutable + #:property prop:custom-write + (lambda (edge o w?) + (fprintf o "#" + (or (node-id (edge-caller edge)) '???) + (or (node-id (edge-callee edge)) '???)))) diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index edc76f9abd..8e6de02422 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -1,7 +1,7 @@ #lang scheme/base (provide format-percent format-source get-hidden) -(require "analyzer.ss") +(require "structs.ss") ;; Format a percent number, possibly doing the division too. If we do the ;; division, then be careful: if we're dividing by zero, then make the result From 86519ae414092cfe49615a348e4d4aac2ffdc304 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 07:35:03 +0000 Subject: [PATCH 06/39] Forgot to actually move the topological sort code svn: r14804 --- collects/profile/analyzer.ss | 55 +-------------------------------- collects/profile/utils.ss | 60 ++++++++++++++++++++++++++++++++++-- 2 files changed, 59 insertions(+), 56 deletions(-) diff --git a/collects/profile/analyzer.ss b/collects/profile/analyzer.ss index f3c765b19c..4fed4e216a 100644 --- a/collects/profile/analyzer.ss +++ b/collects/profile/analyzer.ss @@ -4,7 +4,7 @@ (provide analyze-samples) -(require scheme/list "structs.ss" "utils.ss") +(require "structs.ss" "utils.ss" scheme/list) (define-syntax-rule (with-hash ) (hash-ref! (lambda () ))) @@ -95,59 +95,6 @@ nodes *-node))) -;; A simple topological sort of nodes using BFS, starting from node `x' (which -;; will be given as the special *-node). `subsort' is a `resolver' function to -;; sort nodes on the same level. -(define (topological-sort x subsort) - (let loop ([todo (list x)] [sorted (list x)]) - (if (null? todo) - (reverse sorted) - (let* (;; take the next level of nodes - [next (append-map (lambda (x) (map edge-callee (node-callees x))) - todo)] - ;; remove visited and duplicates - [next (remove-duplicates (remq* sorted next))] - ;; leave only nodes with no other incoming edges - [next* (filter (lambda (node) - (andmap (lambda (e) (memq (edge-caller e) sorted)) - (node-callers node))) - next)] - ;; but if all nodes have other incoming edges, then there must be - ;; a cycle, so just do them now (instead of dropping them) - [next (if (and (null? next*) (pair? next)) next next*)] - ;; sort using subsort - [next (subsort next)]) - (loop next (append (reverse next) sorted)))))) -#| -(define-syntax-rule (letnodes [id ...] body ...) - (let ([id (make-node 'id #f '() 0 0 '() '())] ...) body ...)) -(define (X . -> . Y) - (let ([e (make-edge 0 X 0 Y 0)]) - (set-node-callers! Y (cons e (node-callers Y))) - (set-node-callees! X (cons e (node-callees X))))) -(letnodes [A B C] - (A . -> . B) - (B . -> . C) - (equal? (topological-sort A values) - (list A B C))) -(letnodes [A B C] - ;; check that a cycle doesn't lead to dropping nodes - (A . -> . B) - (A . -> . C) - (B . -> . A) - (B . -> . C) - (C . -> . A) - (C . -> . B) - (null? (remq* (topological-sort A values) (list A B C)))) -(letnodes [A B C D] - (A . -> . B) - (B . -> . C) - (C . -> . D) - (A . -> . D) - (equal? (topological-sort A values) - (list A B C D))) -|# - ;; Groups raw samples by their thread-id, returns a vector with a field for ;; each thread id holding the sample data for that thread. The samples in ;; these are reversed (so they'll be sorted going forward in time). diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index 8e6de02422..dd55f58da8 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -1,13 +1,13 @@ #lang scheme/base -(provide format-percent format-source get-hidden) -(require "structs.ss") +(require "structs.ss" scheme/list) ;; Format a percent number, possibly doing the division too. If we do the ;; division, then be careful: if we're dividing by zero, then make the result ;; zero. This is useful if the total time is zero because we didn't see any ;; activity (for example, the profiled code is just doing a `sleep'), in which ;; case all times will be 0. +(provide format-percent) (define format-percent (case-lambda [(percent) @@ -15,6 +15,7 @@ (format "~a.~a%" (quotient percent 10) (modulo percent 10)))] [(x y) (format-percent (if (zero? y) 0 (/ x y)))])) +(provide format-source) (define (format-source src) (if src (format "~a:~a" @@ -27,6 +28,7 @@ ;; Hide a node if its self time is smaller than the self threshold *and* all of ;; its edges are below the sub-node threshold too -- this avoids confusing ;; output where a node does not have an entry but appears as a caller/callee. +(provide get-hidden) (define (get-hidden profile hide-self% hide-subs%) (define self% (or hide-self% 0)) (define subs% (or hide-subs% 0)) @@ -45,3 +47,57 @@ (cond [(and (<= self% 0) (<= subs% 0)) '()] [(zero? total-time) (profile-nodes profile)] [else (filter hide? (profile-nodes profile))])) + +;; A simple topological sort of nodes using BFS, starting from node `x' (which +;; will be given as the special *-node). `subsort' is a `resolver' function to +;; sort nodes on the same level. +(provide topological-sort) +(define (topological-sort x subsort) + (let loop ([todo (list x)] [sorted (list x)]) + (if (null? todo) + (reverse sorted) + (let* (;; take the next level of nodes + [next (append-map (lambda (x) (map edge-callee (node-callees x))) + todo)] + ;; remove visited and duplicates + [next (remove-duplicates (remq* sorted next))] + ;; leave only nodes with no other incoming edges + [next* (filter (lambda (node) + (andmap (lambda (e) (memq (edge-caller e) sorted)) + (node-callers node))) + next)] + ;; but if all nodes have other incoming edges, then there must be + ;; a cycle, so just do them now (instead of dropping them) + [next (if (and (null? next*) (pair? next)) next next*)] + ;; sort using subsort + [next (subsort next)]) + (loop next (append (reverse next) sorted)))))) +#| +(define-syntax-rule (letnodes [id ...] body ...) + (let ([id (make-node 'id #f '() 0 0 '() '())] ...) body ...)) +(define (X . -> . Y) + (let ([e (make-edge 0 X 0 Y 0)]) + (set-node-callers! Y (cons e (node-callers Y))) + (set-node-callees! X (cons e (node-callees X))))) +(letnodes [A B C] + (A . -> . B) + (B . -> . C) + (equal? (topological-sort A values) + (list A B C))) +(letnodes [A B C] + ;; check that a cycle doesn't lead to dropping nodes + (A . -> . B) + (A . -> . C) + (B . -> . A) + (B . -> . C) + (C . -> . A) + (C . -> . B) + (null? (remq* (topological-sort A values) (list A B C)))) +(letnodes [A B C D] + (A . -> . B) + (B . -> . C) + (C . -> . D) + (A . -> . D) + (equal? (topological-sort A values) + (list A B C D))) +|# From 76574dc619c02361833bce9af1673ad30d1ef46c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 07:36:46 +0000 Subject: [PATCH 07/39] tests need the structs too svn: r14805 --- collects/tests/profile/main.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/tests/profile/main.ss b/collects/tests/profile/main.ss index d7ce5e366d..00d3339e48 100644 --- a/collects/tests/profile/main.ss +++ b/collects/tests/profile/main.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require tests/eli-tester profile/analyzer scheme/match scheme/list) +(require tests/eli-tester profile/structs profile/analyzer + scheme/match scheme/list) (define A '(A . #f)) (define B '(B . #f)) From 0d933c3f86ec2f269fe166f66a9a91300d4e25ff Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 07:47:28 +0000 Subject: [PATCH 08/39] subsort is really any function to apply on a level svn: r14806 --- collects/profile/utils.ss | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index dd55f58da8..b13fd88fcb 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -49,10 +49,12 @@ [else (filter hide? (profile-nodes profile))])) ;; A simple topological sort of nodes using BFS, starting from node `x' (which -;; will be given as the special *-node). `subsort' is a `resolver' function to -;; sort nodes on the same level. +;; will be given as the special *-node). `sublevel' is a function that is +;; applied on each set of nodes at the same level in turn; can be used as a +;; `resolver' function to sort nodes on the same level, or to get a graphical +;; layout. (provide topological-sort) -(define (topological-sort x subsort) +(define (topological-sort x [sublevel #f]) (let loop ([todo (list x)] [sorted (list x)]) (if (null? todo) (reverse sorted) @@ -69,8 +71,8 @@ ;; but if all nodes have other incoming edges, then there must be ;; a cycle, so just do them now (instead of dropping them) [next (if (and (null? next*) (pair? next)) next next*)] - ;; sort using subsort - [next (subsort next)]) + ;; apply sublevel + [next (if sublevel (sublevel next) next)]) (loop next (append (reverse next) sorted)))))) #| (define-syntax-rule (letnodes [id ...] body ...) From 35acf760cd15cb99d1747d547c97fc668f7037d8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 07:50:20 +0000 Subject: [PATCH 09/39] Welcome to a new PLT day. svn: r14807 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index f4127008df..47f5c8ca3f 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "13may2009") +#lang scheme/base (provide stamp) (define stamp "14may2009") From bc22c8a824ee15f67072f225d8e708ee08dfbe7e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 10:34:09 +0000 Subject: [PATCH 10/39] print the *-node appropriately svn: r14808 --- collects/profile/structs.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/profile/structs.ss b/collects/profile/structs.ss index 6512b1f2d3..b8bea412c3 100644 --- a/collects/profile/structs.ss +++ b/collects/profile/structs.ss @@ -34,7 +34,9 @@ (define-struct node (id src thread-ids total self callers callees) #:mutable #:property prop:custom-write - (lambda (node o w?) (fprintf o "#" (or (node-id node) '???)))) + (lambda (node o w?) + (fprintf o "#" + (or (node-id node) (if (node-src node) '??? 'ROOT))))) ;; An edge representing function calls between two nodes: ;; - total: the total time spent while the call was anywhere on the stack. From ccca3b3df6d351ef6ee2f0158b8c7da4a3451b50 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 15:08:56 +0000 Subject: [PATCH 11/39] fix dropping cycles svn: r14811 --- collects/profile/utils.ss | 32 ++------------------------------ 1 file changed, 2 insertions(+), 30 deletions(-) diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index b13fd88fcb..944c59b71e 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -64,8 +64,9 @@ ;; remove visited and duplicates [next (remove-duplicates (remq* sorted next))] ;; leave only nodes with no other incoming edges + [seen (append next sorted)] ; important for cycles [next* (filter (lambda (node) - (andmap (lambda (e) (memq (edge-caller e) sorted)) + (andmap (lambda (e) (memq (edge-caller e) seen)) (node-callers node))) next)] ;; but if all nodes have other incoming edges, then there must be @@ -74,32 +75,3 @@ ;; apply sublevel [next (if sublevel (sublevel next) next)]) (loop next (append (reverse next) sorted)))))) -#| -(define-syntax-rule (letnodes [id ...] body ...) - (let ([id (make-node 'id #f '() 0 0 '() '())] ...) body ...)) -(define (X . -> . Y) - (let ([e (make-edge 0 X 0 Y 0)]) - (set-node-callers! Y (cons e (node-callers Y))) - (set-node-callees! X (cons e (node-callees X))))) -(letnodes [A B C] - (A . -> . B) - (B . -> . C) - (equal? (topological-sort A values) - (list A B C))) -(letnodes [A B C] - ;; check that a cycle doesn't lead to dropping nodes - (A . -> . B) - (A . -> . C) - (B . -> . A) - (B . -> . C) - (C . -> . A) - (C . -> . B) - (null? (remq* (topological-sort A values) (list A B C)))) -(letnodes [A B C D] - (A . -> . B) - (B . -> . C) - (C . -> . D) - (A . -> . D) - (equal? (topological-sort A values) - (list A B C D))) -|# From 9c99a32d29f37cf5dfb06468b3579c94a9a71089 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 15:33:20 +0000 Subject: [PATCH 12/39] added tests for topological-sort svn: r14813 --- collects/tests/profile/main.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/tests/profile/main.ss b/collects/tests/profile/main.ss index 00d3339e48..df3395d556 100644 --- a/collects/tests/profile/main.ss +++ b/collects/tests/profile/main.ss @@ -1,7 +1,7 @@ #lang scheme/base (require tests/eli-tester profile/structs profile/analyzer - scheme/match scheme/list) + scheme/match scheme/list "topsort.ss") (define A '(A . #f)) (define B '(B . #f)) @@ -37,6 +37,8 @@ (test + do (topological-sort-tests) + (match (analyze `(10 [0 0 ,A] [0 1 ,A])) From 40467a005ecfbbdab5f6265ed8723cb51dc78ba5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 15:33:25 +0000 Subject: [PATCH 13/39] added tests for topological-sort svn: r14814 --- collects/tests/profile/topsort.ss | 52 +++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 collects/tests/profile/topsort.ss diff --git a/collects/tests/profile/topsort.ss b/collects/tests/profile/topsort.ss new file mode 100644 index 0000000000..4af71e20b3 --- /dev/null +++ b/collects/tests/profile/topsort.ss @@ -0,0 +1,52 @@ +#lang scheme/base + +(require tests/eli-tester profile/structs profile/utils) + +(define (connect! from to) + (define e (make-edge 0 from 0 to 0)) + (set-node-callers! to (cons e (node-callers to ))) + (set-node-callees! from (cons e (node-callees from)))) + +(define-syntax with-graph + (syntax-rules (->) + [(_ [] -> -> more ...) + (begin (connect! ) (with-graph [] -> more ...))] + [(_ [] -> more ...) + (begin (connect! ) (with-graph [] more ...))] + [(_ [] more ...) (begin more ...)] + [(_ [ ...] more ...) + (let ([ (make-node ' #f '() 0 0 '() '())] ...) + (with-graph [] more ...))])) + +(provide topological-sort-tests) +(define (topological-sort-tests) + (test + + do (with-graph [A B C] + A -> B -> C + (test (topological-sort A values) => (list A B C))) + + do (with-graph [A B C] + ;; check that a cycle doesn't lead to dropping nodes + A -> B -> C -> A + A -> C -> B -> A + (null? (remq* (topological-sort A values) (list A B C)))) + + do (with-graph [A B C D] + A -> B -> C -> D + A -> D + (test (topological-sort A values) => (list A B C D))) + + do (with-graph [A B C] + A -> B + A -> C + C -> C + (test (memq C (topological-sort A)))) + + do (with-graph [A B C D] + A -> B + A -> C -> D + A -> D -> C + (test (memq C (topological-sort A)))) + + )) From ad856384a3cdceaaad6b2c8e8c6e99cb006d24e3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 14 May 2009 19:23:24 +0000 Subject: [PATCH 14/39] svn: r14818 --- collects/mrlib/switchable-button.ss | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/mrlib/switchable-button.ss b/collects/mrlib/switchable-button.ss index b5563438c2..85e795d9c0 100644 --- a/collects/mrlib/switchable-button.ss +++ b/collects/mrlib/switchable-button.ss @@ -56,6 +56,10 @@ [alternate-bitmap bitmap] [vertical-tight? #f]) + (when (and (is-a? label bitmap%) + (not (send label ok?))) + (error 'switchable-button% "label bitmap is not ok?")) + (define/override (get-label) label) (define disable-bitmap (make-dull-mask bitmap)) From ef9ee828bfcce0751679774a9cd9d6bbac258571 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 14 May 2009 19:25:27 +0000 Subject: [PATCH 15/39] svn: r14819 --- collects/scribblings/gui/bitmap-class.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/gui/bitmap-class.scrbl b/collects/scribblings/gui/bitmap-class.scrbl index 4b3d44b21a..e113336066 100644 --- a/collects/scribblings/gui/bitmap-class.scrbl +++ b/collects/scribblings/gui/bitmap-class.scrbl @@ -125,7 +125,7 @@ Returns @scheme[#f] if the bitmap is monochrome, @scheme[#t] otherwise. } -@defmethod[(load-file [name pat-string?] +@defmethod[(load-file [name path-string?] [kind (one-of/c 'unknown 'unknown/mask 'gif 'gif/mask 'jpeg 'png 'png/mask 'xbm 'xpm 'bmp 'pict) @@ -188,7 +188,7 @@ Returns @scheme[#t] if the bitmap is usable (created or changed } -@defmethod[(save-file [name pat-string?] +@defmethod[(save-file [name path-string?] [kind (one-of/c 'png 'jpeg 'xbm 'xpm 'bmp)] [quality (integer-in 0 100) 75]) boolean?]{ From cee5d694ad4f35db3a40175f1c7532e59ffc40b5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 May 2009 19:37:08 +0000 Subject: [PATCH 16/39] fix pasteboard rubber-band drawing svn: r14820 --- collects/mred/private/wxme/pasteboard.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 040ef1a484..9fcbc06ab1 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -166,8 +166,8 @@ (define/private (rubber-band x y w h) (when (and s-admin - (positive? w) - (positive? h)) + (not (zero? w)) + (not (zero? h))) (let-values ([(x w) (if (w . < . 0) (values (+ x w) (- w)) From 34c2dfe021a987248cbfbe184fd3258414d448c4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 14 May 2009 19:49:22 +0000 Subject: [PATCH 17/39] svn: r14821 --- collects/string-constants/english-string-constants.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index c0060edf13..1ed9f3150c 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -426,7 +426,7 @@ please adhere to these guidelines: (show-status-line "Show status-line") (count-columns-from-one "Count column numbers from one") (display-line-numbers "Display line numbers in buffer; not character offsets") - (show-line-and-column-numbers "Show line & column numbers") ; used for popup menu; right click on line/column box in bottom of drs window + (show-line-and-column-numbers "Show line && column numbers") ; used for popup menu; right click on line/column box in bottom of drs window (show-character-offsets "Show character offsets") ; used for popup menu; right click on line/column box in bottom of drs window (enable-keybindings-in-menus "Enable keybindings in menus") (automatically-to-ps "Automatically print to PostScript file") From 6551dbfaa0c133f00786351d02a21f97a2aa2710 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 14 May 2009 20:23:31 +0000 Subject: [PATCH 18/39] PR 10237 svn: r14822 --- collects/errortrace/stacktrace.ss | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/collects/errortrace/stacktrace.ss b/collects/errortrace/stacktrace.ss index 2330bbc144..d2c6856f02 100644 --- a/collects/errortrace/stacktrace.ss +++ b/collects/errortrace/stacktrace.ss @@ -80,7 +80,7 @@ ;; expressions with test suite coverage information. Returning the ;; first argument means no tests coverage information is collected. - ;; test-coverage-point : syntax syntax -> syntax + ;; test-coverage-point : syntax syntax phase -> syntax ;; sets a test coverage point for a single expression (define (test-coverage-point body expr phase) (if (and (test-coverage-enabled) @@ -353,14 +353,29 @@ [(define-values names rhs) top? ;; Can't put annotation on the outside - (let ([marked (with-mark expr - (annotate-named - (one-name #'names) - (syntax rhs) - phase))]) + (let* ([marked + (with-mark expr + (annotate-named + (one-name #'names) + (syntax rhs) + phase))] + [with-coverage + (let loop ([stx #'names] + [obj marked]) + (cond + [(not (syntax? stx)) obj] + [(identifier? stx) + (test-coverage-point obj stx phase)] + [(pair? (syntax-e stx)) + (loop (car (syntax-e stx)) + (loop (cdr (syntax-e stx)) + obj))] + [else obj]))]) (certify expr - (rebuild expr (list (cons #'rhs marked)))))] + (rebuild + expr + (list (cons #'rhs with-coverage)))))] [(begin . exprs) top? (certify From 299cba5adf3b899c14d3bd5148e126ccf43cad9f Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 14 May 2009 22:50:43 +0000 Subject: [PATCH 19/39] svn: r14823 --- collects/lang/private/teachprims.ss | 3 +- collects/lang/private/todo.ss | 297 +++++++++++++++------------- 2 files changed, 160 insertions(+), 140 deletions(-) diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index 4c42694c2f..444a879d97 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -342,4 +342,5 @@ namespace. advanced-cons advanced-list* advanced-append - cyclic-list?)) + cyclic-list?) +) \ No newline at end of file diff --git a/collects/lang/private/todo.ss b/collects/lang/private/todo.ss index 2de7eb166f..a4ba00f93c 100644 --- a/collects/lang/private/todo.ss +++ b/collects/lang/private/todo.ss @@ -10,35 +10,6 @@ string: use string-append instead substring consumes 2 or 3 arguments |# -;; ----------------------------------------------------------------------------- -;; auxiliary stuff, ignore -(require test-engine/scheme-tests) - -(define 1-letter "1-letter string") -(define 1-letter* (format "~as" 1-letter)) - -;; Symbol Any -> Boolean -;; is this a 1-letter string? -(define (1-letter? tag s) - (unless (string? s) - (error tag "~a expected, not a string: ~e" 1-letter s)) - (= (string-length s) 1)) - - -;; Symbol Any -> Boolean -;; is s a list of 1-letter strings -;; effect: not a list, not a list of strings -(define (1-letter*? tag s) - (unless (list? s) - (error tag "list of ~a expected, not a list: ~e" 1-letter* s)) - (for-each - (lambda (c) - (unless (string? c) - (error tag "list of ~a expected, not a string: ~e" 1-letter* c))) - s) - #; (lambda (s) (= 1 (string-length s))) - (andmap (compose (curry = 1) string-length) s)) - (define-syntax (define-teach stx) (syntax-case stx () [(_ level id expr) @@ -54,175 +25,223 @@ substring consumes 2 or 3 arguments id))))])) ;; ----------------------------------------------------------------------------- +;; auxiliary stuff, ignore + +(define 1-LET "1-letter string") +(define 1-LETTER (format "<~a>" 1-LET)) +(define 1-LETTER* (format "" 1-LET)) +(define NAT "") + +;; Symbol Any -> Boolean +;; is this a 1-letter string? +(define (1-letter? tag s) + (unless (string? s) (err tag "~a expected, not a string: ~e" 1-LETTER s)) + (= (string-length s) 1)) + +;; Symbol Any -> Boolean +;; is s a list of 1-letter strings +;; effect: not a list, not a list of strings +(define (1-letter*? tag s) + (unless (list? s) (err tag "~a expected, not a : ~e" 1-LETTER* s)) + (for-each + (lambda (c) + (unless (string? c) (err tag "~a expected, not a : ~e" 1-LETTER* c))) + s) + (andmap (compose (curry = 1) string-length) s)) + +(define (err tag msg-format . args) + (raise + (make-exn:fail:contract + (apply format (string-append (symbol->string tag) ": " msg-format) args) + (current-continuation-marks)))) + +(define cerr + (case-lambda + [(tag check-result format-msg actual) + (unless check-result + (err tag (string-append format-msg " expected, given ~e") actual))] + [(tag check-result format-msg actual snd) + (unless check-result + (err tag (string-append format-msg " for ~a argument expected, given ~e") + snd actual))])) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string-ith + (lambda (s n) + (define f "") + (cerr 'string-ith (string? s) "" s "first") + (cerr 'string-ith (and (number? n) (integer? n) (>= n 0)) NAT n "second") + (let ([l (string-length s)]) + (cerr 'string-ith (< n l) (format f l) n "second")) + (string (string-ref s n)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner replicate + (lambda (n s1) + (cerr 'replicate (and (number? n) (exact-integer? n) (>= n 0)) NAT n) + (cerr 'replicate (string? s1) "" s1) + (apply string-append (build-list n (lambda (i) s1))))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner int->string + (lambda (i) + (cerr 'int->string + (and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111))) + "" + i) + (string (integer->char i)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string->int + (lambda (s) + (cerr 'string->int (1-letter? 'string->int s) 1-LETTER s) + (char->integer (string-ref s 0)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner explode + (lambda (s) + (cerr 'explode (string? s) "" s) + (map string (string->list s)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner implode + (lambda (los) + (cerr 'implode (1-letter*? 'implode los) 1-LETTER* los) + (apply string-append los))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string-numeric? + ;; is this: (number? (string->number s)) enough? + (lambda (s1) + (cerr 'string-numeric? (string? s1) "" s1) + (andmap char-numeric? (string->list s1)))) + +;; ----------------------------------------------------------------------------- + +;; I used copying here and I feel awful. + +(define-teach beginner string-alphabetic? + (lambda (s1) + (cerr 'string-alphabetic? (string? s1) "" s1) + (andmap char-alphabetic? (string->list s1)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string-whitespace? + (lambda (s) + (cerr 'string-upper-case? (string? s) "" s) + (andmap char-whitespace? (string->list s)))) + +;; ----------------------------------------------------------------------------- +;; I copied the next two, and I feel awful, too. + +(define-teach beginner string-upper-case? + (lambda (s) + (cerr 'string-upper-case? (string? s) "" s) + (andmap char-upper-case? (string->list s)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string-lower-case? + (lambda (s) + (cerr 'string-lower-case? (string? s) "" s) + (andmap char-lower-case? (string->list s)))) + +;; ----------------------------------------------------------------------------- +;; ----------------------------------------------------------------------------- +;; ----------------------------------------------------------------------------- + +(require test-engine/scheme-tests) (check-expect (beginner-string-ith "hell" 0) "h") (check-error (beginner-string-ith "hell" 4) (string-append "string-ith:" - " second argument must be between 0 and the length of the given string (4), given " + " " + " for second argument expected, given " "4")) -(define-teach beginner string-ith - (lambda (s n) - (unless (string? s) - (error 'string-ith "first argument must be of type , given ~e" s)) - (unless (and (number? n) (integer? n) (>= n 0)) - (error 'string-ith - "second argument must be of type , given ~e" - n)) - (unless (< n (string-length s)) - (error 'string-ith - "second argument must be between 0 and the length of the given string (~s), given ~a" - (string-length s) n)) - (string (string-ref s n)))) +(check-error + (beginner-string-ith 10 4) + (string-append "string-ith: for first argument expected, given " + "10")) + +(check-error + (beginner-string-ith "10" 'a) + (string-append "string-ith: for second argument expected, given " + "a")) -;; ----------------------------------------------------------------------------- (check-expect (beginner-replicate 3 "a") "aaa") (check-expect (beginner-replicate 3 "ab") "ababab") -(check-error (beginner-replicate 3 10) "replicate: string expected, given 10") - -(define-teach beginner replicate - (lambda (n s1) - (unless (and (number? n) (exact-integer? n) (>= n 0)) - (error 'replicate "(exact) natural number expected, given ~e" n)) - (unless (string? s1) - (error 'replicate "string expected, given ~e" s1)) - (apply string-append (build-list n (lambda (i) s1))))) - -;; ----------------------------------------------------------------------------- +(check-error (beginner-replicate 3 10) "replicate: expected, given 10") (check-expect (beginner-int->string 10) "\n") (check-error (beginner-int->string 56555) (string-append - "int->string: exact integer in [0,55295] or [57344 1114111] expected, given " + "int->string: expected, given " "56555")) (check-error (beginner-int->string "A") (string-append - "int->string: exact integer in [0,55295] or [57344 1114111] expected, given " - "A")) - -(define-teach beginner int->string - (lambda (i) - (unless (and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111))) - (error 'int->string - "exact integer in [0,55295] or [57344 1114111] expected, given ~a" - i)) - (string (integer->char i)))) - -;; ----------------------------------------------------------------------------- + "int->string: expected, given " + (format "~s" "A"))) (check-expect (beginner-string->int "A") 65) (check-error (beginner-string->int 10) - (string-append "string->int: " 1-letter " expected, not a string: 10")) + (string-append "string->int: " 1-LETTER " expected, not a string: 10")) (check-error (beginner-string->int "AB") - (string-append "string->int: " 1-letter " expected, given " (format "~s" "AB"))) - -(define-teach beginner string->int - (lambda (s) - (unless (1-letter? 'string->int s) - (error 'string->int "~a expected, given ~e" 1-letter s)) - (char->integer (string-ref s 0)))) - -;; ----------------------------------------------------------------------------- + (string-append + "string->int: " 1-LETTER " expected, given " (format "~s" "AB"))) (check-expect (beginner-explode "hello") (list "h" "e" "l" "l" "o")) (check-error (beginner-explode 10) - (string-append "explode: string expected, given " "10")) - -(define-teach beginner explode - (lambda (s) - (unless (string? s) - (error 'explode "string expected, given ~e" s)) - (map string (string->list s)))) - -;; ----------------------------------------------------------------------------- + (string-append "explode: expected, given " "10")) (check-expect (beginner-implode (list "h" "e" "l" "l" "o")) "hello") (check-error (beginner-implode 10) - (string-append "implode: list of " 1-letter* - " expected, not a list: 10")) + (string-append "implode: " 1-LETTER* + " expected, not a : 10")) (check-error (beginner-implode '("he" "l")) - (string-append "implode: list of " 1-letter* " expected, given " + (string-append "implode: " 1-LETTER* " expected, given " (format "~s" '("he" "l")))) -(define-teach beginner implode - (lambda (los) - (unless (1-letter*? 'implode los) - (error 'implode "list of ~a expected, given ~e" 1-letter* los)) - (apply string-append los))) - -;; ----------------------------------------------------------------------------- - (check-expect (beginner-string-numeric? "0") true) (check-expect (beginner-string-numeric? "10") true) (check-expect (beginner-string-numeric? "a") false) (check-expect (beginner-string-numeric? "ab") false) (check-error (beginner-string-numeric? 10) - (string-append "string-numeric?: string expected, given 10")) + (string-append "string-numeric?: expected, given 10")) -(define-teach beginner string-numeric? - ;; is this: (number? (string->number s)) enough? - (lambda (s1) - (unless (string? s1) - (error 'string-numeric? "string expected, given ~e" s1)) - (andmap char-numeric? (string->list s1)))) -;; ----------------------------------------------------------------------------- - -;; I used copying here and I feel awful. (check-expect (beginner-string-alphabetic? "a0") false) (check-expect (beginner-string-alphabetic? "a") true) (check-expect (beginner-string-alphabetic? "ba") true) (check-expect (beginner-string-alphabetic? "ab") true) -(define-teach beginner string-alphabetic? - (lambda (s1) - (unless (string? s1) - (error 'string-alphabetic? "string expected, given ~e" s1)) - (andmap char-alphabetic? (string->list s1)))) - -;; ----------------------------------------------------------------------------- - (check-expect (beginner-string-whitespace? " ") true) (check-expect (beginner-string-whitespace? " \t") true) (check-expect (beginner-string-whitespace? "ABC") false) -(define-teach beginner string-whitespace? - (lambda (s) - (unless (string? s) - (error 'string-upper-case? "string expected, given ~e" s)) - (andmap char-whitespace? (string->list s)))) - -;; ----------------------------------------------------------------------------- -;; I copied the next two, and I feel awful, too. (check-expect (beginner-string-upper-case? " ") false) (check-expect (beginner-string-upper-case? "AB\t") false) (check-expect (beginner-string-upper-case? "ABC") true) -(define-teach beginner string-upper-case? - (lambda (s) - (unless (string? s) - (error 'string-upper-case? "string expected, given ~e" s)) - (andmap char-upper-case? (string->list s)))) - -;; ----------------------------------------------------------------------------- - (check-expect (beginner-string-lower-case? " ") false) (check-expect (beginner-string-lower-case? "ab\t") false) (check-expect (beginner-string-lower-case? "abc") true) -(define-teach beginner string-lower-case? - (lambda (s) - (unless (string? s) - (error 'string-lower-case? "string expected, given ~e" s)) - (andmap char-lower-case? (string->list s)))) -;; ----------------------------------------------------------------------------- -(test) \ No newline at end of file +(test) From cfcc1c109335ebc44cabcca17c98ed9399d332d9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 15 May 2009 07:50:16 +0000 Subject: [PATCH 20/39] Welcome to a new PLT day. svn: r14824 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 47f5c8ca3f..a1b33ec7f6 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14may2009") +#lang scheme/base (provide stamp) (define stamp "15may2009") From 05113c4a8f5942d94d164557181556229be502d6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 May 2009 08:53:05 +0000 Subject: [PATCH 21/39] doc typos and guarantee on thread-dead-evt result svn: r14825 --- collects/scribblings/reference/class.scrbl | 8 ++++---- collects/scribblings/reference/threads.scrbl | 4 +++- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 7616f4254f..a136b07a15 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1117,8 +1117,8 @@ Returns an accessor procedure that takes an instance of the class produced by @scheme[class-expr] and returns the value of the object's field with (external) name @scheme[field-id]. -If @scheme[obj-expr] does not produce an object, the -@exnraise[exn:fail:contract]. If the object has no @scheme[field-id] +If @scheme[class-expr] does not produce a class, the +@exnraise[exn:fail:contract]. If the class has no @scheme[field-id] field, the @exnraise[exn:fail:object].} @defform[(class-field-mutator class-expr field-id)]{ @@ -1128,8 +1128,8 @@ produced by @scheme[class-expr] and a value, and sets the value of the object's field with (external) name @scheme[field-id] to the given value. The result is @|void-const|. -If @scheme[obj-expr] does not produce an object, the -@exnraise[exn:fail:contract]. If the object has no @scheme[field-id] +If @scheme[class-expr] does not produce a class, the +@exnraise[exn:fail:contract]. If the class has no @scheme[field-id] field, the @exnraise[exn:fail:object].} @; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/collects/scribblings/reference/threads.scrbl b/collects/scribblings/reference/threads.scrbl index 525096d828..7df71d536d 100644 --- a/collects/scribblings/reference/threads.scrbl +++ b/collects/scribblings/reference/threads.scrbl @@ -199,7 +199,9 @@ Returns a @tech{synchronizable event} (see @secref["sync"]) that is ready if and only if @scheme[thd] has terminated. Unlike using @scheme[thd] directly, however, a reference to the event does not prevent @scheme[thd] from being garbage collected (see -@secref["gc-model"]).} +@secref["gc-model"]). For a given @scheme[thd], +@scheme[thread-dead-evt] always returns the same (i.e., @scheme[eq?]) +result.} @defproc[(thread-resume-evt [thd thread?]) evt?]{ From 2453bc3c6e7382b58e19404329e0b49d6c7c4bd2 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 15 May 2009 16:21:57 +0000 Subject: [PATCH 22/39] added functins for analyzing strings as 1-letter strings svn: r14829 --- collects/tests/mzscheme/beg-adv.ss | 101 +++++++++++++++++++++++++++++ 1 file changed, 101 insertions(+) diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss index 6430ee5e7b..dd4528302f 100644 --- a/collects/tests/mzscheme/beg-adv.ss +++ b/collects/tests/mzscheme/beg-adv.ss @@ -294,3 +294,104 @@ (htdp-top (check-within 1 2 3)) (htdp-test 2 'two 2) (htdp-top-pop 1) + +;; ----------------------------------------------------------------------------- +;; mf's tests for string functions replacing chars + +(htdp-test "h" 'string-ith (string-ith "hell" 0)) + +(htdp-err/rt-test (string-ith "hell" 4) exn:fail:contract? + #; + (string-append + "string-ith:" + " " + " for second argument expected, given " + "4")) + +(htdp-err/rt-test (string-ith 10 4) exn:fail:contract? + #; + (string-append "string-ith: for first argument expected, given " + "10")) + +(htdp-err/rt-test (string-ith "10" 'a) exn:fail:contract? + #; + (string-append "string-ith: for second argument expected, given " + "a")) + +(htdp-test "aaa" 'replicate (replicate 3 "a")) + +(htdp-test "ababab" 'replicate (replicate 3 "ab")) + +(htdp-err/rt-test (replicate 3 10) exn:fail:contract? + #; + "replicate: expected, given 10") + +(htdp-test "\n" 'int->string (int->string 10)) + +(htdp-err/rt-test (int->string 56555) exn:fail:contract? + #; + (string-append + "int->string: expected, given " + "56555")) + +(htdp-err/rt-test (int->string "A") exn:fail:contract? + #; + (string-append + "int->string: expected, given " + (format "~s" "A"))) + +(htdp-test 65 'string->int (string->int "A")) + +(htdp-err/rt-test (string->int 10) exn:fail:contract? + #; + (string-append "string->int: " 1-LETTER " expected, not a string: 10")) + +(htdp-err/rt-test (string->int "AB") exn:fail:contract? + #; + (string-append + "string->int: " 1-LETTER " expected, given " (format "~s" "AB"))) + +(htdp-test (list "h" "e" "l" "l" "o") 'explode (explode "hello")) + +(htdp-err/rt-test (explode 10) exn:fail:contract? + #; + (string-append "explode: expected, given " "10")) + +(htdp-test "hello" 'implode (implode (list "h" "e" "l" "l" "o"))) + +(htdp-err/rt-test (implode 10) exn:fail:contract? + #; + (string-append "implode: " 1-LETTER* " expected, not a : 10")) + +(htdp-err/rt-test (implode (list "he" "l")) exn:fail:contract? + #; + (string-append "implode: " 1-LETTER* " expected, given " + (format "~s" (list "he" "l")))) + +(htdp-test true 'string-numeric? (string-numeric? "0")) +(htdp-test true 'string-numeric? (string-numeric? "10")) +(htdp-test false 'string-numeric? (string-numeric? "a")) +(htdp-test false 'string-numeric? (string-numeric? "ab")) + +(htdp-err/rt-test (string-numeric? 10) exn:fail:contract? + #; + (string-append "string-numeric?: expected, given 10")) + + +(htdp-test false 'string-alphabetic? (string-alphabetic? "a0")) +(htdp-test true 'string-alphabetic? (string-alphabetic? "a")) +(htdp-test true 'string-alphabetic? (string-alphabetic? "ba")) +(htdp-test true 'string-alphabetic? (string-alphabetic? "ab")) + +(htdp-test true 'string-whitespace? (string-whitespace? " ")) +(htdp-test true 'string-whitespace? (string-whitespace? " \t")) +(htdp-test false 'string-whitespace? (string-whitespace? "ABC")) + +(htdp-test false 'string-upper-case? (string-upper-case? " ")) +(htdp-test false 'string-upper-case? (string-upper-case? "AB\t")) +(htdp-test true 'string-upper-case? (string-upper-case? "ABC")) + +(htdp-test false 'string-lower-case? (string-lower-case? " ")) +(htdp-test false 'string-lower-case? (string-lower-case? "ab\t")) +(htdp-test true 'string-lower-case? (string-lower-case? "abc")) + From 0e43e6a0dcf865345373901dd4115facb3e179e4 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 15 May 2009 16:22:17 +0000 Subject: [PATCH 23/39] added functins for analyzing strings as 1-letter strings svn: r14830 --- collects/lang/private/beginner-funs.ss | 25 + collects/lang/private/teachprims.ss | 766 +++++++++++++++---------- 2 files changed, 481 insertions(+), 310 deletions(-) diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index c30d0fb625..9eeea5a304 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -358,11 +358,36 @@ (char->integer (char -> integer) "to lookup the number that corresponds to the" " given character in the ASCII table (if any)")) + ("Strings" (string? (any -> boolean) "to determine whether a value is a string") (string-length (string -> nat) "to determine the length of a string") + + ((beginner-string-ith string-ith) (string -> string) + "to extract the ith 1-letter substring from the given one") + ((beginner-replicate replicate) (string nat -> string) + "to replicate the given string") + ((beginner-int->string int->string) (integer -> string) + "to convert an integer in [0,55295] or [57344 1114111] to a 1-letter string") + ((beginner-string->int string->int) (string -> integer) + "to convert a 1-letter string to an integer in [0,55295] or [57344 1114111]") + ((beginner-explode explode) (string -> (listof string)) + "to translate a string into a list of 1-letter strings") + ((beginner-implode implode) ((listof string) -> string) + "to concatenate the list of 1-letter strings into one string") + ((beginner-string-numeric? string-numeric?) (string -> boolean) + "to determine whether all 'letters' in the string are numeric") + ((beginner-string-alphabetic? string-alphabetic?) (string -> boolean) + "to determine whether all 'letters' in the string are alphabetic") + ((beginner-string-whitespace? string-whitespace?) (string -> boolean) + "to determine whether all 'letters' in the string are white space") + ((beginner-string-upper-case? string-upper-case?) (string -> boolean) + "to determine whether all 'letters' in the string are upper case") + ((beginner-string-lower-case? string-lower-case?) (string -> boolean) + "to determine whether all 'letters' in the string are lower case") + (string (char ... -> string) "(string c1 c2 ...) builds a string") (make-string (nat char -> string) diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index 444a879d97..798bb2e9b2 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -8,339 +8,485 @@ collects/tests/mzscheme/beginner.ss Each one has to run separately, since they mangle the top-level namespace. |# -(module teachprims mzscheme - (require mzlib/list - mzlib/math - mzlib/etc) - - (define-syntax (define-teach stx) - (syntax-case stx () - [(_ level id expr) - (with-syntax ([level-id (datum->syntax-object - (syntax id) - (string->symbol - (format "~a-~a" - (syntax-object->datum (syntax level)) - (syntax-object->datum (syntax id)))) - (syntax id))]) - (syntax (define level-id - (let ([id expr]) - id))))])) +;; MF: switched from +;; module teachprims mzscheme +;; to +#lang scheme - (define-teach beginner list? - (lambda (x) - (or (null? x) (pair? x)))) - - ;; Don't need this anymore, since we just check for pairs: - #; - (define cyclic-list? - (lambda (l) - (or (list? l) - (and (pair? l) - (let loop ([hare (cdr l)][turtle l]) - (cond - [(eq? hare turtle) #t] - [(not (pair? hare)) #f] - [(eq? (cdr hare) turtle) #t] - [(not (pair? (cdr hare))) #f] - [else (loop (cddr hare) (cdr turtle))])))))) +(require mzlib/list + mzlib/math + mzlib/etc) - (define cyclic-list? beginner-list?) +(define-syntax (define-teach stx) + (syntax-case stx () + [(_ level id expr) + (with-syntax ([level-id (datum->syntax + (syntax id) + (string->symbol + (format "~a-~a" + (syntax->datum (syntax level)) + (syntax->datum (syntax id)))) + (syntax id))]) + (syntax (define level-id + (let ([id expr]) + id))))])) - (define (build-arg-list args) - (let loop ([args args][n 0]) +(define-teach beginner list? + (lambda (x) + (or (null? x) (pair? x)))) + +;; Don't need this anymore, since we just check for pairs: +#; +(define cyclic-list? + (lambda (l) + (or (list? l) + (and (pair? l) + (let loop ([hare (cdr l)][turtle l]) + (cond + [(eq? hare turtle) #t] + [(not (pair? hare)) #f] + [(eq? (cdr hare) turtle) #t] + [(not (pair? (cdr hare))) #f] + [else (loop (cddr hare) (cdr turtle))])))))) + +(define cyclic-list? beginner-list?) + +(define (build-arg-list args) + (let loop ([args args][n 0]) + (cond + [(null? args) ""] + [(= n 5) " ..."] + [else + (format " ~e~a" (car args) (loop (cdr args) (add1 n)))]))) + +(define (mk-check-second ok? type) + (lambda (prim-name a b) + (unless (ok? b) + (raise + (make-exn:fail:contract + (format "~a: second argument must be of type <~a>, given ~e and ~e" + prim-name type + a b) + (current-continuation-marks)))))) + +(define check-second + (mk-check-second beginner-list? "list")) + +(define check-second/cycle + (mk-check-second cyclic-list? "list or cyclic list")) + +(define (mk-check-last ok? type) + (lambda (prim-name args) + (let loop ([l args]) (cond - [(null? args) ""] - [(= n 5) " ..."] - [else - (format " ~e~a" (car args) (loop (cdr args) (add1 n)))]))) - - (define (mk-check-second ok? type) - (lambda (prim-name a b) - (unless (ok? b) - (raise - (make-exn:fail:contract - (format "~a: second argument must be of type <~a>, given ~e and ~e" - prim-name type - a b) - (current-continuation-marks)))))) - - (define check-second - (mk-check-second beginner-list? "list")) - - (define check-second/cycle - (mk-check-second cyclic-list? "list or cyclic list")) - - (define (mk-check-last ok? type) - (lambda (prim-name args) - (let loop ([l args]) - (cond - [(null? l) (void)] - [(null? (cdr l)) - (let ([last (car l)]) - (unless (ok? last) - (raise - (make-exn:fail:contract - (format "~a: last argument must be of type <~a>, given ~e; other args:~a" - prim-name type - last - ;; all-but-last: - (build-arg-list - (let loop ([args args]) - (cond - [(null? (cdr args)) null] - [else (cons (car args) (loop (cdr args)))])))) - (current-continuation-marks)))))] - [else (loop (cdr l))])))) - - (define check-last - (mk-check-last beginner-list? "list")) - - (define check-last/cycle - (mk-check-last cyclic-list? "list or cyclic list")) - - (define (check-three a b c prim-name ok1? 1type ok2? 2type ok3? 3type) - (let ([bad - (lambda (v which type) + [(null? l) (void)] + [(null? (cdr l)) + (let ([last (car l)]) + (unless (ok? last) (raise (make-exn:fail:contract - (format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e" - prim-name which type - a b c) - (current-continuation-marks))))]) - (unless (ok1? a) (bad a "first" 1type)) - (unless (ok2? b) (bad b "second" 2type)) - (unless (ok3? c) (bad c "third" 3type)))) + (format "~a: last argument must be of type <~a>, given ~e; other args:~a" + prim-name type + last + ;; all-but-last: + (build-arg-list + (let loop ([args args]) + (cond + [(null? (cdr args)) null] + [else (cons (car args) (loop (cdr args)))])))) + (current-continuation-marks)))))] + [else (loop (cdr l))])))) - (define (positive-real? v) - (and (real? v) (>= v 0))) +(define check-last + (mk-check-last beginner-list? "list")) - (define (false? v) (eq? v #f)) +(define check-last/cycle + (mk-check-last cyclic-list? "list or cyclic list")) - (define-teach beginner not - (lambda (a) - (unless (boolean? a) - (raise - (make-exn:fail:contract - (format "not: expected either true or false; given ~e" a) - (current-continuation-marks)))) - (not a))) +(define (check-three a b c prim-name ok1? 1type ok2? 2type ok3? 3type) + (let ([bad + (lambda (v which type) + (raise + (make-exn:fail:contract + (format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e" + prim-name which type + a b c) + (current-continuation-marks))))]) + (unless (ok1? a) (bad a "first" 1type)) + (unless (ok2? b) (bad b "second" 2type)) + (unless (ok3? c) (bad c "third" 3type)))) - (define-teach beginner random - (lambda (a) - (random a))) +(define (positive-real? v) + (and (real? v) (>= v 0))) - (define-teach beginner + - (lambda (a b . args) - (apply + a b args))) +(define (false? v) (eq? v #f)) - (define-teach beginner / - (lambda (a b . args) - (apply / a b args))) - - (define-teach beginner * - (lambda (a b . args) - (apply * a b args))) - - (define-teach beginner sqr - (lambda (a) - (unless (number? a) - (raise - (make-exn:fail:contract - (format "sqr: expected number; given ~e" a) - (current-continuation-marks)))) - (sqr a))) - - (define-teach beginner member - (lambda (a b) - (check-second 'member a b) - (not (boolean? (member a b))))) +(define-teach beginner not + (lambda (a) + (unless (boolean? a) + (raise + (make-exn:fail:contract + (format "not: expected either true or false; given ~e" a) + (current-continuation-marks)))) + (not a))) - (define-teach beginner cons - (lambda (a b) - (check-second 'cons a b) - (cons a b))) - - (define-teach beginner list* - (lambda x - (check-last 'list* x) - (apply list* x))) - - (define-teach beginner append - (lambda (a b . x) - (check-last 'append (cons a (cons b x))) - (apply append a b x))) - - (define-teach beginner error - (lambda (sym str) - (unless (and (symbol? sym) - (string? str)) - (raise - (make-exn:fail:contract - (format "error: expected a symbol and a string, got ~e and ~e" - sym str) - (current-continuation-marks)))) - (error sym "~a" str))) +(define-teach beginner random + (lambda (a) + (random a))) - (define-teach beginner struct? - (lambda (x) - (not (or (number? x) - (boolean? x) - (pair? x) - (symbol? x) - (string? x) - (procedure? x) - (vector? x) - (char? x) - (port? x) - (eof-object? x) - (void? x))))) +(define-teach beginner + + (lambda (a b . args) + (apply + a b args))) - (define-teach beginner exit - (lambda () (exit))) - - (define (tequal? a b epsilon) - (let* ([ht (make-hash-table)] - [union-find (lambda (a) - (let loop ([prev a] - [prev-prev a]) - (let ([v (hash-table-get ht prev #f)]) - (if v - (loop v prev) - (begin - (let loop ([a a]) - (unless (eq? a prev-prev) - (let ([v (hash-table-get ht a)]) - (hash-table-put! ht a prev) - (loop v)))) - prev)))))] - [union-equal!? (lambda (a b) - (let ([a (union-find a)] - [b (union-find b)]) - (if (eq? a b) - #t - (begin - (hash-table-put! ht b a) - #f))))]) - (let ? ([a a][b b]) - (cond - [(real? a) - (and (real? b) - (beginner-=~ a b epsilon))] - [(union-equal!? a b) #t] - [else (equal?/recur a b ?)])))) +(define-teach beginner / + (lambda (a b . args) + (apply / a b args))) - (define-teach beginner equal? - (lambda (a b) - (equal? a b))) +(define-teach beginner * + (lambda (a b . args) + (apply * a b args))) - (define-teach beginner =~ - (lambda (a b c) - (check-three a b c '=~ real? 'real real? 'real positive-real? 'non-negative-real) - (<= (- a c) b (+ a c)))) +(define-teach beginner sqr + (lambda (a) + (unless (number? a) + (raise + (make-exn:fail:contract + (format "sqr: expected number; given ~e" a) + (current-continuation-marks)))) + (sqr a))) - (define-teach beginner equal~? - (lambda (a b c) - (check-three a b c 'equal~? values 'any values 'any positive-real? 'non-negative-real) - (tequal? a b c))) +(define-teach beginner member + (lambda (a b) + (check-second 'member a b) + (not (boolean? (member a b))))) - (define (qcheck quicksort fmt-str . x) - (raise - (make-exn:fail:contract - (string-append (format "~a : " quicksort) (apply format fmt-str x)) - (current-continuation-marks)))) +(define-teach beginner cons + (lambda (a b) + (check-second 'cons a b) + (cons a b))) - (define (do-sort l cmp? name) +(define-teach beginner list* + (lambda x + (check-last 'list* x) + (apply list* x))) + +(define-teach beginner append + (lambda (a b . x) + (check-last 'append (cons a (cons b x))) + (apply append a b x))) + +(define-teach beginner error + (lambda (sym str) + (unless (and (symbol? sym) + (string? str)) + (raise + (make-exn:fail:contract + (format "error: expected a symbol and a string, got ~e and ~e" + sym str) + (current-continuation-marks)))) + (error sym "~a" str))) + +(define-teach beginner struct? + (lambda (x) + (not (or (number? x) + (boolean? x) + (pair? x) + (symbol? x) + (string? x) + (procedure? x) + (vector? x) + (char? x) + (port? x) + (eof-object? x) + (void? x))))) + +(define-teach beginner exit + (lambda () (exit))) + +(define (tequal? a b epsilon) + (let* ([ht (make-hash)] ;; make-hash + [union-find (lambda (a) + (let loop ([prev a] + [prev-prev a]) + (let ([v (hash-ref ht prev #f)]) + (if v + (loop v prev) + (begin + (let loop ([a a]) + (unless (eq? a prev-prev) + (let ([v (hash-ref ht a)]) + (hash-set! ht a prev) + (loop v)))) + prev)))))] + [union-equal!? (lambda (a b) + (let ([a (union-find a)] + [b (union-find b)]) + (if (eq? a b) + #t + (begin + (hash-set! ht b a) + #f))))]) + (let ? ([a a][b b]) + (cond + [(real? a) + (and (real? b) + (beginner-=~ a b epsilon))] + [(union-equal!? a b) #t] + [else (equal?/recur a b ?)])))) + +(define-teach beginner equal? + (lambda (a b) + (equal? a b))) + +(define-teach beginner =~ + (lambda (a b c) + (check-three a b c '=~ real? 'real real? 'real positive-real? 'non-negative-real) + (<= (- a c) b (+ a c)))) + +(define-teach beginner equal~? + (lambda (a b c) + (check-three a b c 'equal~? values 'any values 'any positive-real? 'non-negative-real) + (tequal? a b c))) + +(define (qcheck quicksort fmt-str . x) + (raise + (make-exn:fail:contract + (string-append (format "~a : " quicksort) (apply format fmt-str x)) + (current-continuation-marks)))) + +(define (do-sort l cmp? name) + (unless (beginner-list? l) + (qcheck name "first argument must be of type , given ~e" l)) + (unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2)) + (qcheck name "second argument must be a that accepts two arguments, given ~e" cmp?)) + (sort l (lambda (x y) + (define r (cmp? x y)) + (unless (boolean? r) + (qcheck name "the results of the procedure argument must be of type , produced ~e" r)) + r))) + +(define-teach intermediate quicksort + (lambda (l cmp?) + (do-sort l cmp? 'quicksort))) +(define-teach intermediate sort + (lambda (l cmp?) + (do-sort l cmp? 'sort))) + +(define-teach intermediate foldr + (lambda (f e l) + (unless (and (procedure? f) (procedure-arity-includes? f 2)) + (qcheck 'foldr "first argument must be a that accepts two arguments, given ~e" f)) (unless (beginner-list? l) - (qcheck name "first argument must be of type , given ~e" l)) - (unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2)) - (qcheck name "second argument must be a that accepts two arguments, given ~e" cmp?)) - (sort l (lambda (x y) - (define r (cmp? x y)) - (unless (boolean? r) - (qcheck name "the results of the procedure argument must be of type , produced ~e" r)) - r))) - - (define-teach intermediate quicksort - (lambda (l cmp?) - (do-sort l cmp? 'quicksort))) - (define-teach intermediate sort - (lambda (l cmp?) - (do-sort l cmp? 'sort))) + (qcheck 'foldr "third argument must be of type , given ~e" l)) + (foldr f e l))) - (define-teach intermediate foldr - (lambda (f e l) - (unless (and (procedure? f) (procedure-arity-includes? f 2)) - (qcheck 'foldr "first argument must be a that accepts two arguments, given ~e" f)) - (unless (beginner-list? l) - (qcheck 'foldr "third argument must be of type , given ~e" l)) - (foldr f e l))) +(define-teach intermediate foldl + (lambda (f e l) + (unless (and (procedure? f) (procedure-arity-includes? f 2)) + (qcheck 'foldl "first argument must be a that accepts two arguments, given ~e" f)) + (unless (beginner-list? l) + (qcheck 'foldl "third argument must be of type , given ~e" l)) + (foldl f e l))) - (define-teach intermediate foldl - (lambda (f e l) - (unless (and (procedure? f) (procedure-arity-includes? f 2)) - (qcheck 'foldl "first argument must be a that accepts two arguments, given ~e" f)) - (unless (beginner-list? l) - (qcheck 'foldl "third argument must be of type , given ~e" l)) - (foldl f e l))) +(define-teach intermediate build-string + (lambda (n f) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (qcheck 'build-string "second argument must be a that accepts one argument, given ~e" f)) + (unless (and (number? n) (integer? n) (>= n 0)) + (qcheck 'build-string "first argument must be of type , given ~e" n)) + (build-string n (lambda (i) + (define r (f i)) + (unless (char? r) + (qcheck 'build-string + "second argument must be a that produces a , given ~e, which produced ~e for ~e" f r i)) + r)))) - (define-teach intermediate build-string - (lambda (n f) - (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (qcheck 'build-string "second argument must be a that accepts one argument, given ~e" f)) - (unless (and (number? n) (integer? n) (>= n 0)) - (qcheck 'build-string "first argument must be of type , given ~e" n)) - (build-string n (lambda (i) - (define r (f i)) - (unless (char? r) - (qcheck 'build-string - "second argument must be a that produces a , given ~e, which produced ~e for ~e" f r i)) - r)))) - - - (define-teach advanced cons - (lambda (a b) - (check-second/cycle 'cons a b) - (cons a b))) - - (define-teach advanced list* - (lambda x - (check-last/cycle 'list* x) - (apply list* x))) - - (define-teach advanced append - (lambda x - (check-last/cycle 'append x) - (apply append x))) - - (provide - false? - beginner-not - beginner-random - beginner-+ - beginner-/ - beginner-* - beginner-sqr - beginner-list? - beginner-member - beginner-cons - beginner-list* - beginner-append - beginner-error - beginner-struct? - beginner-exit - beginner-equal? - beginner-equal~? - beginner-=~ - intermediate-quicksort - intermediate-sort - intermediate-foldr - intermediate-foldl - intermediate-build-string - advanced-cons - advanced-list* - advanced-append - cyclic-list?) -) \ No newline at end of file + +(define-teach advanced cons + (lambda (a b) + (check-second/cycle 'cons a b) + (cons a b))) + +(define-teach advanced list* + (lambda x + (check-last/cycle 'list* x) + (apply list* x))) + +(define-teach advanced append + (lambda x + (check-last/cycle 'append x) + (apply append x))) + +(provide + false? + beginner-not + beginner-random + beginner-+ + beginner-/ + beginner-* + beginner-sqr + beginner-list? + beginner-member + beginner-cons + beginner-list* + beginner-append + beginner-error + beginner-struct? + beginner-exit + beginner-equal? + beginner-equal~? + beginner-=~ + intermediate-quicksort + intermediate-sort + intermediate-foldr + intermediate-foldl + intermediate-build-string + advanced-cons + advanced-list* + advanced-append + cyclic-list?) + +;; ----------------------------------------------------------------------------- +;; auxiliary stuff, ignore + +(define 1-LET "1-letter string") +(define 1-LETTER (format "<~a>" 1-LET)) +(define 1-LETTER* (format "" 1-LET)) +(define NAT "") + +;; Symbol Any -> Boolean +;; is this a 1-letter string? +(define (1-letter? tag s) + (unless (string? s) (err tag "~a expected, not a string: ~e" 1-LETTER s)) + (= (string-length s) 1)) + +;; Symbol Any -> Boolean +;; is s a list of 1-letter strings +;; effect: not a list, not a list of strings +(define (1-letter*? tag s) + (unless (list? s) (err tag "~a expected, not a : ~e" 1-LETTER* s)) + (for-each + (lambda (c) + (unless (string? c) (err tag "~a expected, not a : ~e" 1-LETTER* c))) + s) + (andmap (compose (curry = 1) string-length) s)) + +(define (err tag msg-format . args) + (raise + (make-exn:fail:contract + (apply format (string-append (symbol->string tag) ": " msg-format) args) + (current-continuation-marks)))) + +(define cerr + (case-lambda + [(tag check-result format-msg actual) + (unless check-result + (err tag (string-append format-msg " expected, given ~e") actual))] + [(tag check-result format-msg actual snd) + (unless check-result + (err tag (string-append format-msg " for ~a argument expected, given ~e") + snd actual))])) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string-ith + (lambda (s n) + (define f "") + (cerr 'string-ith (string? s) "" s "first") + (cerr 'string-ith (and (number? n) (integer? n) (>= n 0)) NAT n "second") + (let ([l (string-length s)]) + (cerr 'string-ith (< n l) (format f l) n "second")) + (string (string-ref s n)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner replicate + (lambda (n s1) + (cerr 'replicate (and (number? n) (exact-integer? n) (>= n 0)) NAT n) + (cerr 'replicate (string? s1) "" s1) + (apply string-append (build-list n (lambda (i) s1))))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner int->string + (lambda (i) + (cerr 'int->string + (and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111))) + "" + i) + (string (integer->char i)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string->int + (lambda (s) + (cerr 'string->int (1-letter? 'string->int s) 1-LETTER s) + (char->integer (string-ref s 0)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner explode + (lambda (s) + (cerr 'explode (string? s) "" s) + (map string (string->list s)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner implode + (lambda (los) + (cerr 'implode (1-letter*? 'implode los) 1-LETTER* los) + (apply string-append los))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string-numeric? + ;; is this: (number? (string->number s)) enough? + (lambda (s1) + (cerr 'string-numeric? (string? s1) "" s1) + (andmap char-numeric? (string->list s1)))) + +;; ----------------------------------------------------------------------------- + +;; I used copying here and I feel awful. + +(define-teach beginner string-alphabetic? + (lambda (s1) + (cerr 'string-alphabetic? (string? s1) "" s1) + (andmap char-alphabetic? (string->list s1)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string-whitespace? + (lambda (s) + (cerr 'string-upper-case? (string? s) "" s) + (andmap char-whitespace? (string->list s)))) + +;; ----------------------------------------------------------------------------- +;; I copied the next two, and I feel awful, too. + +(define-teach beginner string-upper-case? + (lambda (s) + (cerr 'string-upper-case? (string? s) "" s) + (andmap char-upper-case? (string->list s)))) + +;; ----------------------------------------------------------------------------- + +(define-teach beginner string-lower-case? + (lambda (s) + (cerr 'string-lower-case? (string? s) "" s) + (andmap char-lower-case? (string->list s)))) + +(provide + beginner-string-ith + beginner-replicate + beginner-int->string + beginner-string->int + beginner-explode + beginner-implode + beginner-string-numeric? + beginner-string-alphabetic? + beginner-string-whitespace? + beginner-string-upper-case? + beginner-string-lower-case?) \ No newline at end of file From 6a4c1018593f9a40ad36c8c73dd45deaa268a224 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 15 May 2009 16:30:39 +0000 Subject: [PATCH 24/39] arithmetic functions should be standard svn: r14831 --- collects/lang/private/intermediate-funs.ss | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/collects/lang/private/intermediate-funs.ss b/collects/lang/private/intermediate-funs.ss index 6fdd3c5100..38659dc4e7 100644 --- a/collects/lang/private/intermediate-funs.ss +++ b/collects/lang/private/intermediate-funs.ss @@ -9,6 +9,13 @@ procedures (all-from beginner: lang/private/beginner-funs procedures) + ("Numbers (relaxed conditions)" + + (+ (number ... -> number) "to add all given numbers") + (* (number ... -> number) "to multiply all given numbers") + (- (number ... -> number) "to subtract from the first all remaining numbers") + (/ (number ... -> number) "to divide the first by all remaining numbers") + ) ("Higher-Order Functions" (map ((X ... -> Z) (listof X) ... -> (listof Z)) "to construct a new list by applying a function to each item on one or more existing lists") From dff15857f09da0223b4400f4f9db29e15e2ca9b8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 15 May 2009 17:39:09 +0000 Subject: [PATCH 25/39] svn: r14832 --- collects/slideshow/pict.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index 7b32fe8013..5f2994cbde 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -89,7 +89,7 @@ #:under? [under? #f] #:solid? [solid? #t] #:hide-arrowhead? [hide-arrowhead? #f]) - (if (not sa ea) + (if (not (or sa ea)) (finish-pin (launder (t:pin-arrows-line sz (ghost p) src src-find dest dest-find From 305a38a0c0dc0cc6e34bc5e35bb43ae995280a88 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 15 May 2009 18:26:16 +0000 Subject: [PATCH 26/39] arithmetic functions should be standard svn: r14833 --- collects/tests/mzscheme/beg-adv.ss | 8 -------- collects/tests/mzscheme/beg-bega.ss | 12 ++++++++++++ collects/tests/mzscheme/beg-intm.ss | 1 + collects/tests/mzscheme/intm-adv.ss | 12 ++++++++---- collects/tests/mzscheme/intmlam-adv.ss | 2 +- 5 files changed, 22 insertions(+), 13 deletions(-) diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss index dd4528302f..72942ea8c4 100644 --- a/collects/tests/mzscheme/beg-adv.ss +++ b/collects/tests/mzscheme/beg-adv.ss @@ -133,14 +133,6 @@ (htdp-test #t 'eq? (eq? #t true)) (htdp-test #t 'eq? (eq? #f false)) -(htdp-err/rt-test (+) exn:application:arity?) -(htdp-err/rt-test (+ 1) exn:application:arity?) -(htdp-err/rt-test (*) exn:application:arity?) -(htdp-err/rt-test (* 1) exn:application:arity?) -(htdp-err/rt-test (-) exn:application:arity?) -(htdp-err/rt-test (/) exn:application:arity?) -(htdp-err/rt-test (/ 1) exn:application:arity?) - (htdp-test -9 '- (- 9)) (htdp-top (define-struct an-example-structure (first-field second-field))) diff --git a/collects/tests/mzscheme/beg-bega.ss b/collects/tests/mzscheme/beg-bega.ss index 971bfa993d..644a2561bd 100644 --- a/collects/tests/mzscheme/beg-bega.ss +++ b/collects/tests/mzscheme/beg-bega.ss @@ -44,3 +44,15 @@ (htdp-top-pop 1) (htdp-teachpack-pop) + +(htdp-err/rt-test (+) exn:application:arity?) +(htdp-err/rt-test (+ 1) exn:application:arity?) +(htdp-err/rt-test (*) exn:application:arity?) +(htdp-err/rt-test (* 1) exn:application:arity?) +(htdp-err/rt-test (-) exn:application:arity?) +(htdp-err/rt-test (/) exn:application:arity?) +(htdp-err/rt-test (/ 1) exn:application:arity?) + +(err/rt-test (+) exn:application:arity?) + + diff --git a/collects/tests/mzscheme/beg-intm.ss b/collects/tests/mzscheme/beg-intm.ss index a67cdaa8f7..11c7fd4b82 100644 --- a/collects/tests/mzscheme/beg-intm.ss +++ b/collects/tests/mzscheme/beg-intm.ss @@ -9,3 +9,4 @@ (htdp-syntax-test #'(lambda (x) 10)) (htdp-syntax-test #'(lambda (f) (f f))) + diff --git a/collects/tests/mzscheme/intm-adv.ss b/collects/tests/mzscheme/intm-adv.ss index ff116a24bb..bbf6955d21 100644 --- a/collects/tests/mzscheme/intm-adv.ss +++ b/collects/tests/mzscheme/intm-adv.ss @@ -1,10 +1,6 @@ ;; These are true for beginner, but the operators are syntax, so ;; arity-test doesn't work. -(arity-test + 2 -1) -(arity-test * 2 -1) -(arity-test / 2 -1) -(arity-test - 1 -1) (htdp-syntax-test #'local) (htdp-syntax-test #'(local)) @@ -108,3 +104,11 @@ (htdp-err/rt-test (build-string 2 add1) "build-string : second argument must be a that produces a , given #, which produced 1 for 0") + +(htdp-test 0 '+ (+)) +(htdp-test 1 '+ (+ 1)) +(htdp-test 1 '* (*)) +(htdp-test 1 '* (* 1)) +;(htdp-test (-) exn:application:arity?) +;(htdp-err/rt-test (/) exn:application:arity?) +;(htdp-test 1 (/ 1) exn:application:arity?) diff --git a/collects/tests/mzscheme/intmlam-adv.ss b/collects/tests/mzscheme/intmlam-adv.ss index e8294b1a9c..3745d00903 100644 --- a/collects/tests/mzscheme/intmlam-adv.ss +++ b/collects/tests/mzscheme/intmlam-adv.ss @@ -11,6 +11,6 @@ (test 'id f11 'id) (err/rt-test (1 2 3)) -(err/rt-test (+) exn:application:arity?) + From 27e4c708c791a732f9c5fe016159c450ed3605f2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 15 May 2009 19:16:56 +0000 Subject: [PATCH 27/39] better layout for topological-sort svn: r14834 --- collects/profile/analyzer.ss | 8 ++-- collects/profile/utils.ss | 48 +++++++++---------- collects/tests/profile/topsort.ss | 77 ++++++++++++++++--------------- 3 files changed, 67 insertions(+), 66 deletions(-) diff --git a/collects/profile/analyzer.ss b/collects/profile/analyzer.ss index 4fed4e216a..946e30942c 100644 --- a/collects/profile/analyzer.ss +++ b/collects/profile/analyzer.ss @@ -78,10 +78,10 @@ (set-node-total! *-node total-time) ;; convert the nodes from the hash to a list, do a topological sort, and then ;; sort by total time (combining both guarantees(?) sensible order) - (let ([nodes (remq *-node (topological-sort - *-node - (lambda (nodes) - (sort nodes > #:key node-total))))]) + (let* ([nodes (topological-sort *-node)] + [nodes (append-map (lambda (nodes) (sort nodes > #:key node-total)) + nodes)] + [nodes (remq *-node nodes)]) ;; sort all the edges in the nodes according to total time (for ([n (in-list nodes)]) (set-node-callees! n (sort (node-callees n) > #:key edge-callee-time)) diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index 944c59b71e..d94f02a22b 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -48,30 +48,26 @@ [(zero? total-time) (profile-nodes profile)] [else (filter hide? (profile-nodes profile))])) -;; A simple topological sort of nodes using BFS, starting from node `x' (which -;; will be given as the special *-node). `sublevel' is a function that is -;; applied on each set of nodes at the same level in turn; can be used as a -;; `resolver' function to sort nodes on the same level, or to get a graphical -;; layout. +;; A simple topological sort of nodes using the Khan method, starting +;; from node `x' (which will be given as the special *-node). The +;; result is a list of node lists, each one corresponds to one level. (provide topological-sort) -(define (topological-sort x [sublevel #f]) - (let loop ([todo (list x)] [sorted (list x)]) - (if (null? todo) - (reverse sorted) - (let* (;; take the next level of nodes - [next (append-map (lambda (x) (map edge-callee (node-callees x))) - todo)] - ;; remove visited and duplicates - [next (remove-duplicates (remq* sorted next))] - ;; leave only nodes with no other incoming edges - [seen (append next sorted)] ; important for cycles - [next* (filter (lambda (node) - (andmap (lambda (e) (memq (edge-caller e) seen)) - (node-callers node))) - next)] - ;; but if all nodes have other incoming edges, then there must be - ;; a cycle, so just do them now (instead of dropping them) - [next (if (and (null? next*) (pair? next)) next next*)] - ;; apply sublevel - [next (if sublevel (sublevel next) next)]) - (loop next (append (reverse next) sorted)))))) +(define (topological-sort x) + (let loop ([todo (list x)] [sorted (list (list x))] [seen (list x)]) + (let* (;; take the next level of nodes + [next (append-map (lambda (x) (map edge-callee (node-callees x))) + todo)] + ;; remove visited and duplicates + [next (remove-duplicates (remq* seen next))] + ;; leave only nodes with no other incoming edges + [seen* (append next seen)] ; important for cycles + [next* (filter (lambda (node) + (andmap (lambda (e) (memq (edge-caller e) seen*)) + (node-callers node))) + next)] + ;; but if all nodes have other incoming edges, then there must be a + ;; cycle, so just do them now (instead of dropping them) + [next (if (null? next*) next next*)]) + (if (null? next) + (reverse sorted) + (loop next (cons next sorted) (append next seen)))))) diff --git a/collects/tests/profile/topsort.ss b/collects/tests/profile/topsort.ss index 4af71e20b3..7ab2160c05 100644 --- a/collects/tests/profile/topsort.ss +++ b/collects/tests/profile/topsort.ss @@ -1,52 +1,57 @@ #lang scheme/base -(require tests/eli-tester profile/structs profile/utils) +(require tests/eli-tester profile/structs profile/utils + scheme/list scheme/match) (define (connect! from to) - (define e (make-edge 0 from 0 to 0)) - (set-node-callers! to (cons e (node-callers to ))) - (set-node-callees! from (cons e (node-callees from)))) + (define edge (make-edge 0 from 0 to 0)) + (set-node-callers! to (cons edge (node-callers to ))) + (set-node-callees! from (cons edge (node-callees from)))) -(define-syntax with-graph - (syntax-rules (->) - [(_ [] -> -> more ...) - (begin (connect! ) (with-graph [] -> more ...))] - [(_ [] -> more ...) - (begin (connect! ) (with-graph [] more ...))] - [(_ [] more ...) (begin more ...)] - [(_ [ ...] more ...) - (let ([ (make-node ' #f '() 0 0 '() '())] ...) - (with-graph [] more ...))])) +(define (sort-graph . edges) + (define names (remove-duplicates (remq* '(->) (append* edges)))) + (define nodes (map (lambda (sym) (make-node sym #f '() 0 0 '() '())) names)) + (define ->node (make-immutable-hasheq (map cons names nodes))) + (for ([edges edges]) + (let loop ([xs edges]) + (match xs + [(list from '-> to '-> _ ...) + (connect! (hash-ref ->node from) (hash-ref ->node to)) + (loop (cddr xs))] + [(list from '-> to _ ...) + (connect! (hash-ref ->node from) (hash-ref ->node to)) + (loop (cdddr xs))] + ['() (void)]))) + (map (lambda (nodes) (map node-id nodes)) (topological-sort (car nodes)))) + +(define (same-levels graph levels) + (define sorted (sort-graph graph)) + (define (set=? l1 l2) (null? (append (remq* l1 l2) (remq* l2 l1)))) + (andmap set=? sorted levels)) (provide topological-sort-tests) (define (topological-sort-tests) (test - do (with-graph [A B C] - A -> B -> C - (test (topological-sort A values) => (list A B C))) + (same-levels '(A -> B -> C) + '((A) (B) (C))) - do (with-graph [A B C] - ;; check that a cycle doesn't lead to dropping nodes - A -> B -> C -> A - A -> C -> B -> A - (null? (remq* (topological-sort A values) (list A B C)))) + (same-levels '(A -> B -> C -> A + A -> C -> B -> A) + '((A) (B C))) - do (with-graph [A B C D] - A -> B -> C -> D - A -> D - (test (topological-sort A values) => (list A B C D))) + (same-levels '(A -> B -> C -> D + A -> D) + '((A) (B) (C) (D))) - do (with-graph [A B C] - A -> B - A -> C - C -> C - (test (memq C (topological-sort A)))) + (same-levels '(A -> B + A -> C + C -> C) + '((A) (B C))) - do (with-graph [A B C D] - A -> B - A -> C -> D - A -> D -> C - (test (memq C (topological-sort A)))) + (same-levels '(A -> B + A -> C -> D + A -> D -> C) + '((A) (B C D))) )) From 8e79a2aed5289f12bc9a111ab50e5a66ab9b24fd Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 15 May 2009 19:28:38 +0000 Subject: [PATCH 28/39] don't include the *-node in the topological-sort output svn: r14835 --- collects/profile/analyzer.ss | 6 ++---- collects/profile/utils.ss | 9 ++++---- collects/tests/profile/topsort.ss | 34 +++++++++++++++---------------- 3 files changed, 24 insertions(+), 25 deletions(-) diff --git a/collects/profile/analyzer.ss b/collects/profile/analyzer.ss index 946e30942c..664aee7f55 100644 --- a/collects/profile/analyzer.ss +++ b/collects/profile/analyzer.ss @@ -78,10 +78,8 @@ (set-node-total! *-node total-time) ;; convert the nodes from the hash to a list, do a topological sort, and then ;; sort by total time (combining both guarantees(?) sensible order) - (let* ([nodes (topological-sort *-node)] - [nodes (append-map (lambda (nodes) (sort nodes > #:key node-total)) - nodes)] - [nodes (remq *-node nodes)]) + (let ([nodes (append-map (lambda (nodes) (sort nodes > #:key node-total)) + (topological-sort *-node))]) ;; sort all the edges in the nodes according to total time (for ([n (in-list nodes)]) (set-node-callees! n (sort (node-callees n) > #:key edge-callee-time)) diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index d94f02a22b..abf5a99337 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -48,12 +48,13 @@ [(zero? total-time) (profile-nodes profile)] [else (filter hide? (profile-nodes profile))])) -;; A simple topological sort of nodes using the Khan method, starting -;; from node `x' (which will be given as the special *-node). The -;; result is a list of node lists, each one corresponds to one level. +;; A simple topological sort of nodes using the Khan method, starting from node +;; `x' (which will be given as the special *-node). The result is a list of +;; node lists, each one corresponds to one level. Conceptually, the input node +;; is always only item in the first level, so it is not included in the result. (provide topological-sort) (define (topological-sort x) - (let loop ([todo (list x)] [sorted (list (list x))] [seen (list x)]) + (let loop ([todo (list x)] [sorted '()] [seen (list x)]) (let* (;; take the next level of nodes [next (append-map (lambda (x) (map edge-callee (node-callees x))) todo)] diff --git a/collects/tests/profile/topsort.ss b/collects/tests/profile/topsort.ss index 7ab2160c05..f43dc4a029 100644 --- a/collects/tests/profile/topsort.ss +++ b/collects/tests/profile/topsort.ss @@ -33,25 +33,25 @@ (define (topological-sort-tests) (test - (same-levels '(A -> B -> C) + (same-levels '(* -> A -> B) + '((A) (B))) + + (same-levels '(* -> A -> B -> * + * -> B -> A -> *) + '((A B))) + + (same-levels '(* -> A -> B -> C + * -> C) '((A) (B) (C))) - (same-levels '(A -> B -> C -> A - A -> C -> B -> A) - '((A) (B C))) + (same-levels '(* -> A + * -> B + B -> B) + '((A B))) - (same-levels '(A -> B -> C -> D - A -> D) - '((A) (B) (C) (D))) - - (same-levels '(A -> B - A -> C - C -> C) - '((A) (B C))) - - (same-levels '(A -> B - A -> C -> D - A -> D -> C) - '((A) (B C D))) + (same-levels '(* -> A + * -> B -> C + * -> C -> B) + '((A B C))) )) From 399d07907ab76222e927171ad73f2b7a6737b175 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 15 May 2009 22:01:11 +0000 Subject: [PATCH 29/39] error in tp uses contract exn now, misc svn: r14839 --- collects/htdp/Test/matrix-test.ss | 6 +++--- collects/htdp/Test/world-add-line.ss | 1 + collects/htdp/Test/world.ss | 15 ++++++++------- collects/htdp/error.ss | 6 ++++-- 4 files changed, 16 insertions(+), 12 deletions(-) diff --git a/collects/htdp/Test/matrix-test.ss b/collects/htdp/Test/matrix-test.ss index fa20fde1f3..079afe5b3d 100644 --- a/collects/htdp/Test/matrix-test.ss +++ b/collects/htdp/Test/matrix-test.ss @@ -2,7 +2,7 @@ ;; about the language level of this file in a form that our tools can easily process. #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname matrix-test) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) ;(require htdp/matrix-invisible) -(require htdp/matrix) +(require (lib "matrix.ss" "htdp")) (define r1 '((a00 a01 a02) (a10 a11 a12))) @@ -52,5 +52,5 @@ ;; --- IMPERATIVE --- (check-expect (matrix-ref m1 0 0) 'a00) -(define m1-modified (matrix-set! m1 0 0 'xxx)) ;; <-------- uncomment this and the test engine breaks -(check-expect (matrix-ref m1 0 0) 'xxx) +;(define m1-modified (matrix-set! m1 0 0 'xxx)) ;; <-------- uncomment this and the test engine breaks +;(check-expect (matrix-ref m1 0 0) 'xxx) diff --git a/collects/htdp/Test/world-add-line.ss b/collects/htdp/Test/world-add-line.ss index 123c2881cf..cf36121b78 100644 --- a/collects/htdp/Test/world-add-line.ss +++ b/collects/htdp/Test/world-add-line.ss @@ -1,6 +1,7 @@ ;; The first three lines of this file were inserted by DrScheme. They record metadata ;; about the language level of this file in a form that our tools can easily process. #reader(lib "htdp-beginner-reader.ss" "lang")((modname world-add-line) (read-case-sensitive #t) (teachpacks ((lib "world.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "world.ss" "teachpack" "htdp"))))) +(require (lib "world.ss" "htdp")) ;(require htdp/world) (define plain (empty-scene 100 100)) diff --git a/collects/htdp/Test/world.ss b/collects/htdp/Test/world.ss index f86950f05f..6315d906b1 100644 --- a/collects/htdp/Test/world.ss +++ b/collects/htdp/Test/world.ss @@ -1,6 +1,6 @@ ;; The first three lines of this file were inserted by DrScheme. They record metadata ;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world) (read-case-sensitive #t) (teachpacks ((lib "world.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "world.ss" "teachpack" "htdp"))))) +#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp") (lib "foo.ss" "installed-teachpacks"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp") (lib "foo.ss" "installed-teachpacks"))))) ;; testing world ;; World = Nat @@ -27,14 +27,15 @@ (check-expect (key=? 'a #\a) false) (check-expect (key=? 'left 'left) true) -(check-error (key=? 'a 0) "key=?: expected as first argument, given: 0") +(check-error (key=? 'a 0) "key=?: expected as second argument, given: 0") ;; run world run -(big-bang 100 100 .01 world0 true) ;; get ready to create images +xxx -(on-redraw world->image) -(on-tick-event world->next) -(on-key-event world->steer) -(stop-when zero?) +(big-bang world0 + (on-draw world->image) + (on-tick world->next) + (on-key world->steer) + (stop-when zero?)) diff --git a/collects/htdp/error.ss b/collects/htdp/error.ss index 592fc11e3b..b6320f9c0a 100644 --- a/collects/htdp/error.ss +++ b/collects/htdp/error.ss @@ -34,8 +34,10 @@ (define-struct (tp-exn exn) ()) (define (tp-error name fmt . args) - (raise (make-tp-exn (string-append (format "~a: " name) (apply format fmt args)) - (current-continuation-marks)))) + (raise + (make-exn:fail:contract #; make-tp-exn + (string-append (format "~a: " name) (apply format fmt args)) + (current-continuation-marks)))) (define (number->ord i) (if (= i 0) From b09e905da08a260da962305bee77c5e8804e96f0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 May 2009 02:20:13 +0000 Subject: [PATCH 30/39] fix intm+ function export to omit replaced beg math ops svn: r14841 --- collects/lang/private/intermediate-funs.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/lang/private/intermediate-funs.ss b/collects/lang/private/intermediate-funs.ss index 38659dc4e7..31dc926ca0 100644 --- a/collects/lang/private/intermediate-funs.ss +++ b/collects/lang/private/intermediate-funs.ss @@ -7,7 +7,8 @@ (provide-and-document procedures - (all-from beginner: lang/private/beginner-funs procedures) + (all-from-except beginner: lang/private/beginner-funs procedures + + * - /) ("Numbers (relaxed conditions)" From 8ecbe78e982f2de7bd05e610b0c707477262b892 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 16 May 2009 06:08:47 +0000 Subject: [PATCH 31/39] typo (PR10242) svn: r14843 --- collects/planet/planet.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index 2bed6520da..7b94672b61 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -38,7 +38,7 @@ how to use PLaneT by example. @subsection[#:tag "finding-a-package"]{Finding a Package} -If you are new to PLaneT, the first thing to to is visit +If you are new to PLaneT, the first thing to do is visit @link["http://planet.plt-scheme.org/"]{the PLaneT repository web site} and see what packages are available. People contribute new PLaneT packages all the time --- if you want to be notified whenever a new or From a793d3b021940e1fd6932f039116d702f66ac95a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 16 May 2009 07:50:18 +0000 Subject: [PATCH 32/39] Welcome to a new PLT day. svn: r14844 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index a1b33ec7f6..e53443d52b 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "15may2009") +#lang scheme/base (provide stamp) (define stamp "16may2009") From ee7b4404aba57a1576b73787a14c858b5811e4ca Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 May 2009 16:11:17 +0000 Subject: [PATCH 33/39] -Wl,--export-dynamic for OpenBSD svn: r14845 --- src/configure | 2 +- src/mzscheme/configure.ac | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/configure b/src/configure index 08062f6ff2..101e722a28 100755 --- a/src/configure +++ b/src/configure @@ -5787,7 +5787,7 @@ case $OS in DYN_CFLAGS="-fPIC" ;; OpenBSD) - LIBS="$LIBS -rdynamic" + LIBS="$LIBS -rdynamic -Wl,--export-dynamic" ;; NetBSD) LIBS="$LIBS -rdynamic" diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index 6236202a05..0bff9d4886 100644 --- a/src/mzscheme/configure.ac +++ b/src/mzscheme/configure.ac @@ -521,7 +521,7 @@ case $OS in DYN_CFLAGS="-fPIC" ;; OpenBSD) - LIBS="$LIBS -rdynamic" + LIBS="$LIBS -rdynamic -Wl,--export-dynamic" ;; NetBSD) LIBS="$LIBS -rdynamic" From 00cab7cfd2ea2436c2431a6730e2e146ea39aa31 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 17 May 2009 01:45:49 +0000 Subject: [PATCH 34/39] update version numbers for the v4.2 release svn: r14847 --- src/mzscheme/src/schvers.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 3f88efcb15..675708fc7a 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.5.5" +#define MZSCHEME_VERSION "4.2.0.1" #define MZSCHEME_VERSION_X 4 -#define MZSCHEME_VERSION_Y 1 -#define MZSCHEME_VERSION_Z 5 -#define MZSCHEME_VERSION_W 5 +#define MZSCHEME_VERSION_Y 2 +#define MZSCHEME_VERSION_Z 0 +#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) From 7efdd033bf6c3a686a5e6647348d7a00fae343d0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 17 May 2009 06:41:49 +0000 Subject: [PATCH 35/39] Welcome to a new PLT day. svn: r14849 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 12 ++++++------ src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 23 insertions(+), 23 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index e53443d52b..d93619c4f3 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "16may2009") +#lang scheme/base (provide stamp) (define stamp "17may2009") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 3fa6665bec..d2830a183a 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Sun, 17 May 2009 12:31:51 +0000 Subject: [PATCH 36/39] identifier-prune-lexical-context (4.2.0.2) svn: r14850 --- collects/compiler/zo-parse.ss | 2 + collects/scheme/package.ss | 11 +- collects/scheme/private/define-struct.ss | 12 +- collects/scheme/private/stxloc.ss | 22 +- collects/scribblings/reference/stx-ops.scrbl | 15 + .../scribblings/reference/stx-patterns.scrbl | 10 + doc/release-notes/mzscheme/HISTORY.txt | 7 + src/mzscheme/src/cstartup.inc | 592 +++++++++--------- src/mzscheme/src/eval.c | 8 +- src/mzscheme/src/module.c | 3 + src/mzscheme/src/schminc.h | 2 +- src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/stxobj.c | 411 ++++++++++-- src/mzscheme/src/stypes.h | 145 ++--- src/mzscheme/src/type.c | 1 + 15 files changed, 794 insertions(+), 451 deletions(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 1f04af58ec..8af27954f9 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -505,6 +505,7 @@ (define-form-struct wrap ()) (define-form-struct (lexical-rename wrap) (alist)) (define-form-struct (phase-shift wrap) (amt src dest)) +(define-form-struct (prune wrap) (sym)) (define-form-struct (module-rename wrap) (phase kind set-id unmarshals renames mark-renames plus-kern?)) (define-form-struct all-from-module (path phase src-phase exceptions prefix)) @@ -691,6 +692,7 @@ '(#%mark-barrier)] [(box? a) (match (unbox a) + [(list (? symbol?) ...) (make-prune (unbox a))] [`#(,amt ,src ,dest #f) (make-phase-shift amt (parse-module-path-index cp src) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 38bbbed2db..167c2c45dc 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -266,10 +266,13 @@ (let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))] [exports (map (lambda (id) (pre-package-id id def-ctxes)) exports-renamed)]) - (values exports exports-renamed)))))]) - (with-syntax ([(export ...) exports] - [(renamed ...) exports-renamed] - [(hidden ...) (complement new-bindings exports-renamed)]) + (values exports exports-renamed)))))] + [(prune) + (lambda (stx) + (identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))]) + (with-syntax ([(export ...) (map prune exports)] + [(renamed ...) (map prune exports-renamed)] + [(hidden ...) (map prune (complement new-bindings exports-renamed))]) (let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes) (reverse rev-forms))]) (if (eq? mode '#:begin) diff --git a/collects/scheme/private/define-struct.ss b/collects/scheme/private/define-struct.ss index a9cd43091e..31cfd2b2c4 100644 --- a/collects/scheme/private/define-struct.ss +++ b/collects/scheme/private/define-struct.ss @@ -369,7 +369,9 @@ stx super-id)) (and super-expr - #`(check-struct-type 'fm #,super-expr)))]) + #`(check-struct-type 'fm #,super-expr)))] + [prune (lambda (stx) (identifier-prune-lexical-context stx + (list (syntax-e stx) '#%top)))]) (let ([run-time-defns (lambda () (quasisyntax/loc stx @@ -424,7 +426,7 @@ (let ([protect (lambda (sel) (and sel (if (syntax-e sel) - #`(quote-syntax #,sel) + #`(quote-syntax #,(prune sel)) sel)))] [mk-info (if super-info-checked? #'make-checked-struct-info @@ -434,9 +436,9 @@ (#,mk-info (lambda () (list - (quote-syntax #,struct:) - (quote-syntax #,make-) - (quote-syntax #,?) + (quote-syntax #,(prune struct:)) + (quote-syntax #,(prune make-)) + (quote-syntax #,(prune ?)) (list #,@(map protect (reverse sels)) #,@(if super-info diff --git a/collects/scheme/private/stxloc.ss b/collects/scheme/private/stxloc.ss index a4b51be4ce..ee4f6bab8a 100644 --- a/collects/scheme/private/stxloc.ss +++ b/collects/scheme/private/stxloc.ss @@ -43,4 +43,24 @@ (syntax (syntax pattern)) (syntax (relocate loc (syntax pattern))))]))) - (#%provide syntax/loc syntax-case* syntax-case ... _)) + (-define-syntax quote-syntax/prune + (lambda (stx) + (syntax-case** #f #t stx () free-identifier=? + [(_ id) + (if (symbol? (syntax-e #'id)) + (datum->syntax #'here + (list (quote-syntax quote-syntax) + (identifier-prune-lexical-context (syntax id) + (list + (syntax-e (syntax id)) + '#%top))) + stx + #f + stx) + (raise-syntax-error + #f + "expected an identifier" + stx + #'id))]))) + + (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case ... _)) diff --git a/collects/scribblings/reference/stx-ops.scrbl b/collects/scribblings/reference/stx-ops.scrbl index 0afe1326f1..b8555aca84 100644 --- a/collects/scribblings/reference/stx-ops.scrbl +++ b/collects/scribblings/reference/stx-ops.scrbl @@ -224,3 +224,18 @@ in the corresponding generated name, which is useful for debugging purposes. The generated identifiers are built with interned symbols (not @scheme[gensym]s), so the limitations described with @scheme[current-compile] do not apply.} + + +@defproc[(identifier-prune-lexical-context [id-stx identifier?] + [syms (listof symbol?) (list (syntax-e id-stx))]) + identifier?]{ + +Returns an identifier with the same binding as @scheme[id-stx], but +without lexical information from @scheme[id-stx] that does not apply +to the symbols in @scheme[syms], where even further extension of the +lexical information drops information for other symbols. In +particular, transferring the lexical context via +@scheme[datum->syntax] from the result of this function to a symbol +other than one in @scheme[syms] produces a identifier with no binding. + +See also @scheme[quote-syntax/prune].} diff --git a/collects/scribblings/reference/stx-patterns.scrbl b/collects/scribblings/reference/stx-patterns.scrbl index 0adbac5306..cb7d1968e2 100644 --- a/collects/scribblings/reference/stx-patterns.scrbl +++ b/collects/scribblings/reference/stx-patterns.scrbl @@ -358,6 +358,16 @@ Like @scheme[quasisyntax], but with source-location assignment like @scheme[syntax/loc].} +@defform[(quote-syntax/prune id)]{ + +Like @scheme[quote-syntax], but the lexical context of @scheme[id] is +pruned via @scheme[identifier-prune-lexical-context] to including +binding only for the symbolic name of @scheme[id] and for +@scheme['#%top]. Use this form to quote an identifier when its lexical +information will not be transferred to other syntax objects (except +maybe to @scheme['#%top] for a top-level binding).} + + @defform[(syntax-rules (literal-id ...) [(id . pattern) template] ...)]{ diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 29c5680471..cb86c4a169 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,10 @@ +Version 4.1.5.6 +Added identifier-prune-lexical-context and quote-syntax/prune + +Version 4.1.5.4 +Changed visiting of modules at phase N to happen only when compilation + at phase N starts + Version 4.1.5.3 Changed provide to convert an exported rename transformer to its free-identifier=? target diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 695378257d..8be5c71a8f 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,5 +1,5 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,50,0,0,0,1,0,0,3,0,12,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,54,50,0,0,0,1,0,0,3,0,12,0, 17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78, 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,1,1,27,1,35,1,43,1,53,1,89,1,128,1,167, @@ -14,13 +14,13 @@ 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109, 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97, -35,11,8,168,228,95,159,2,15,35,35,159,2,14,35,35,159,2,14,35,35, +35,11,8,136,232,95,159,2,15,35,35,159,2,14,35,35,159,2,14,35,35, 16,20,2,3,2,1,2,5,2,1,2,6,2,1,2,7,2,1,2,8,2, 1,2,9,2,1,2,10,2,1,2,4,2,1,2,11,2,1,2,12,2,1, -97,36,11,8,168,228,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2, -2,2,1,2,2,96,11,11,8,168,228,16,0,96,37,11,8,168,228,16,0, +97,36,11,8,136,232,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2, +2,2,1,2,2,96,11,11,8,136,232,16,0,96,37,11,8,136,232,16,0, 13,16,4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31, -8,30,8,29,8,28,8,27,93,8,224,47,57,0,0,95,9,8,224,47,57, +8,30,8,29,8,28,8,27,93,8,224,15,58,0,0,95,9,8,224,15,58, 0,0,2,1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251, 22,75,2,16,248,22,90,23,200,2,12,249,22,65,2,17,248,22,92,23,202, 1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75,2, @@ -29,16 +29,16 @@ 36,28,248,22,73,248,22,67,23,195,2,248,22,66,193,249,22,128,4,80,158, 38,35,251,22,75,2,16,248,22,66,23,200,2,249,22,65,2,12,248,22,67, 23,202,1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4, -11,11,2,18,3,1,7,101,110,118,57,56,49,54,16,4,11,11,2,19,3, -1,7,101,110,118,57,56,49,55,93,8,224,48,57,0,0,95,9,8,224,48, -57,0,0,2,1,27,248,22,67,248,22,135,4,23,197,1,28,248,22,73,23, +11,11,2,18,3,1,7,101,110,118,57,56,51,50,16,4,11,11,2,19,3, +1,7,101,110,118,57,56,51,51,93,8,224,16,58,0,0,95,9,8,224,16, +58,0,0,2,1,27,248,22,67,248,22,135,4,23,197,1,28,248,22,73,23, 194,2,20,15,159,36,35,36,28,248,22,73,248,22,67,23,195,2,248,22,66, 193,249,22,128,4,80,158,38,35,250,22,75,2,20,248,22,75,249,22,75,248, 22,75,2,21,248,22,66,23,202,2,251,22,75,2,16,2,21,2,21,249,22, 65,2,4,248,22,67,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8, -28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,49,57,16,4, -11,11,2,19,3,1,7,101,110,118,57,56,50,48,93,8,224,49,57,0,0, -95,9,8,224,49,57,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,51,53,16,4, +11,11,2,19,3,1,7,101,110,118,57,56,51,54,93,8,224,17,58,0,0, +95,9,8,224,17,58,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194, 249,22,65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135, 4,23,197,1,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4,248, 22,66,23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39, @@ -62,15 +62,15 @@ 102,105,114,115,116,11,2,24,201,250,22,76,2,20,9,248,22,67,203,27,248, 22,67,248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35, 36,249,22,128,4,80,158,38,35,27,248,22,135,4,248,22,66,23,198,2,28, -249,22,164,8,62,61,62,248,22,129,4,248,22,90,23,197,2,250,22,75,2, +249,22,165,8,62,61,62,248,22,129,4,248,22,90,23,197,2,250,22,75,2, 20,248,22,75,249,22,75,21,93,2,25,248,22,66,199,250,22,76,2,3,249, 22,75,2,25,249,22,75,248,22,99,203,2,25,248,22,67,202,251,22,75,2, -16,28,249,22,164,8,248,22,129,4,248,22,66,23,201,2,64,101,108,115,101, +16,28,249,22,165,8,248,22,129,4,248,22,66,23,201,2,64,101,108,115,101, 10,248,22,66,23,198,2,250,22,76,2,20,9,248,22,67,23,201,1,249,22, 65,2,3,248,22,67,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16, -4,11,11,2,18,3,1,7,101,110,118,57,56,52,50,16,4,11,11,2,19, -3,1,7,101,110,118,57,56,52,51,93,8,224,50,57,0,0,18,16,2,158, -94,10,64,118,111,105,100,8,47,95,9,8,224,50,57,0,0,2,1,27,248, +4,11,11,2,18,3,1,7,101,110,118,57,56,53,56,16,4,11,11,2,19, +3,1,7,101,110,118,57,56,53,57,93,8,224,18,58,0,0,18,16,2,158, +94,10,64,118,111,105,100,8,47,95,9,8,224,18,58,0,0,2,1,27,248, 22,67,248,22,135,4,196,249,22,128,4,80,158,38,35,28,248,22,53,248,22, 129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,199,248,22,90, 198,27,248,22,129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66, @@ -100,13 +100,13 @@ EVAL_ONE_SIZED_STR((char *)expr, 2048); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,59,0,0,0,1,0,0,13,0,18,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,54,59,0,0,0,1,0,0,13,0,18,0, 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226, 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1, 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100, -6,114,6,148,6,164,6,14,8,28,8,191,8,194,9,194,10,201,10,208,10, -215,10,90,11,103,11,58,12,160,12,173,12,195,12,147,13,51,14,123,15,131, -15,139,15,165,15,20,16,0,0,9,19,0,0,72,112,97,116,104,45,115,116, +6,114,6,148,6,164,6,14,8,28,8,191,8,194,9,194,10,201,10,209,10, +217,10,92,11,105,11,60,12,162,12,175,12,197,12,149,13,53,14,125,15,134, +15,143,15,169,15,24,16,0,0,13,19,0,0,72,112,97,116,104,45,115,116, 114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,108,45,99,97,115, 101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,108,112,97,116,104, 77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,111,110,75,99,111, @@ -132,222 +132,222 @@ 116,101,32,115,116,114,105,110,103,6,36,36,99,97,110,110,111,116,32,97,100, 100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32, 112,97,116,104,58,32,5,0,27,20,14,159,80,158,36,50,250,80,158,39,51, -249,22,27,11,80,158,41,50,22,184,12,10,248,22,157,5,23,196,2,28,248, -22,154,6,23,194,2,12,87,94,248,22,168,8,23,194,1,248,80,159,37,53, +249,22,27,11,80,158,41,50,22,185,12,10,248,22,158,5,23,196,2,28,248, +22,155,6,23,194,2,12,87,94,248,22,169,8,23,194,1,248,80,159,37,53, 36,195,28,248,22,73,23,195,2,9,27,248,22,66,23,196,2,27,28,248,22, -165,13,23,195,2,23,194,1,28,248,22,164,13,23,195,2,249,22,166,13,23, -196,1,250,80,158,42,48,248,22,180,13,2,19,11,10,250,80,158,40,48,248, -22,180,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,168,13,249, -22,166,13,23,198,1,247,22,181,13,27,248,22,67,23,200,1,28,248,22,73, -23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,165,13,23,195,2,23, -194,1,28,248,22,164,13,23,195,2,249,22,166,13,23,196,1,250,80,158,47, -48,248,22,180,13,2,19,11,10,250,80,158,45,48,248,22,180,13,2,19,23, -197,1,10,28,23,193,2,249,22,65,248,22,168,13,249,22,166,13,23,198,1, -247,22,181,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1, +166,13,23,195,2,23,194,1,28,248,22,165,13,23,195,2,249,22,167,13,23, +196,1,250,80,158,42,48,248,22,181,13,2,19,11,10,250,80,158,40,48,248, +22,181,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,169,13,249, +22,167,13,23,198,1,247,22,182,13,27,248,22,67,23,200,1,28,248,22,73, +23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,166,13,23,195,2,23, +194,1,28,248,22,165,13,23,195,2,249,22,167,13,23,196,1,250,80,158,47, +48,248,22,181,13,2,19,11,10,250,80,158,45,48,248,22,181,13,2,19,23, +197,1,10,28,23,193,2,249,22,65,248,22,169,13,249,22,167,13,23,198,1, +247,22,182,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1, 248,80,159,43,52,36,248,22,67,23,197,1,87,94,23,193,1,27,248,22,67, 23,198,1,28,248,22,73,23,194,2,9,27,248,22,66,23,195,2,27,28,248, -22,165,13,23,195,2,23,194,1,28,248,22,164,13,23,195,2,249,22,166,13, -23,196,1,250,80,158,45,48,248,22,180,13,2,19,11,10,250,80,158,43,48, -248,22,180,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,168,13, -249,22,166,13,23,198,1,247,22,181,13,248,80,159,43,52,36,248,22,67,23, -199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,141,13,23,195,2,28, -23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,195,2,27,248,22,163, -13,195,28,192,192,248,22,164,13,195,11,87,94,28,28,248,22,142,13,23,195, -2,10,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, -248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,192,87, -94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,76,110,111,114, +22,166,13,23,195,2,23,194,1,28,248,22,165,13,23,195,2,249,22,167,13, +23,196,1,250,80,158,45,48,248,22,181,13,2,19,11,10,250,80,158,43,48, +248,22,181,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,169,13, +249,22,167,13,23,198,1,247,22,182,13,248,80,159,43,52,36,248,22,67,23, +199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,142,13,23,195,2,28, +23,193,2,192,87,94,23,193,1,28,248,22,160,6,23,195,2,27,248,22,164, +13,195,28,192,192,248,22,165,13,195,11,87,94,28,28,248,22,143,13,23,195, +2,10,27,248,22,142,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, +248,22,160,6,23,196,2,27,248,22,164,13,23,197,2,28,23,193,2,192,87, +94,23,193,1,248,22,165,13,23,197,2,11,12,250,22,133,9,76,110,111,114, 109,97,108,45,112,97,116,104,45,99,97,115,101,6,42,42,112,97,116,104,32, 40,102,111,114,32,97,110,121,32,115,121,115,116,101,109,41,32,111,114,32,118, 97,108,105,100,45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,28,28, -248,22,142,13,23,195,2,249,22,164,8,248,22,143,13,23,197,2,2,20,249, -22,164,8,247,22,178,7,2,20,27,28,248,22,159,6,23,196,2,23,195,2, -248,22,168,7,248,22,146,13,23,197,2,28,249,22,129,14,0,21,35,114,120, +248,22,143,13,23,195,2,249,22,165,8,248,22,144,13,23,197,2,2,20,249, +22,165,8,247,22,179,7,2,20,27,28,248,22,160,6,23,196,2,23,195,2, +248,22,169,7,248,22,147,13,23,197,2,28,249,22,130,14,0,21,35,114,120, 34,94,91,92,92,93,91,92,92,93,91,63,93,91,92,92,93,34,23,195,2, -28,248,22,159,6,195,248,22,149,13,195,194,27,248,22,134,7,23,195,1,249, -22,150,13,248,22,171,7,250,22,135,14,0,6,35,114,120,34,47,34,28,249, -22,129,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, -92,92,93,42,36,34,23,201,2,23,199,1,250,22,135,14,0,19,35,114,120, +28,248,22,160,6,195,248,22,150,13,195,194,27,248,22,135,7,23,195,1,249, +22,151,13,248,22,172,7,250,22,136,14,0,6,35,114,120,34,47,34,28,249, +22,130,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, +92,92,93,42,36,34,23,201,2,23,199,1,250,22,136,14,0,19,35,114,120, 34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,23,202,1,6,2, -2,92,49,80,159,43,36,37,2,20,28,248,22,159,6,194,248,22,149,13,194, -193,87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,23,196, -2,2,21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22, -169,10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23, -87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,1, -28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,192, -87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,23,196,2, -2,21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,169, -10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23,87, -94,87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,195,2, -21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,169,10, -248,22,188,6,250,22,143,7,2,22,199,23,201,1,247,22,23,249,22,3,89, -162,8,44,36,49,9,223,2,33,33,196,248,22,160,11,249,22,135,11,23,196, +2,92,49,80,159,43,36,37,2,20,28,248,22,160,6,194,248,22,150,13,194, +193,87,94,28,27,248,22,142,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,160,6,23,196,2,27,248,22,164,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,165,13,23,197,2,11,12,250,22,133,9,23,196, +2,2,21,23,197,2,28,248,22,164,13,23,195,2,12,248,22,161,11,249,22, +170,10,248,22,189,6,250,22,144,7,2,22,23,200,1,23,201,1,247,22,23, +87,94,28,27,248,22,142,13,23,196,2,28,23,193,2,192,87,94,23,193,1, +28,248,22,160,6,23,196,2,27,248,22,164,13,23,197,2,28,23,193,2,192, +87,94,23,193,1,248,22,165,13,23,197,2,11,12,250,22,133,9,23,196,2, +2,21,23,197,2,28,248,22,164,13,23,195,2,12,248,22,161,11,249,22,170, +10,248,22,189,6,250,22,144,7,2,22,23,200,1,23,201,1,247,22,23,87, +94,87,94,28,27,248,22,142,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,160,6,23,196,2,27,248,22,164,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,165,13,23,197,2,11,12,250,22,133,9,195,2, +21,23,197,2,28,248,22,164,13,23,195,2,12,248,22,161,11,249,22,170,10, +248,22,189,6,250,22,144,7,2,22,199,23,201,1,247,22,23,249,22,3,89, +162,8,44,36,49,9,223,2,33,33,196,248,22,161,11,249,22,136,11,23,196, 1,247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41, 36,2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162, 43,41,58,65,99,108,111,111,112,222,33,38,28,248,22,73,23,199,2,87,94, -23,198,1,248,23,196,1,251,22,143,7,2,23,23,199,1,28,248,22,73,23, -203,2,87,94,23,202,1,23,201,1,250,22,1,22,159,13,23,204,1,23,205, -1,23,198,1,27,249,22,159,13,248,22,66,23,202,2,23,199,2,28,248,22, -154,13,23,194,2,27,250,22,1,22,159,13,23,197,1,23,202,2,28,248,22, -154,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22, -73,23,194,2,87,94,23,193,1,248,23,199,1,251,22,143,7,2,23,23,202, -1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,159, -13,23,207,1,23,208,1,23,201,1,27,249,22,159,13,248,22,66,23,197,2, -23,202,2,28,248,22,154,13,23,194,2,27,250,22,1,22,159,13,23,197,1, -204,28,248,22,154,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201, +23,198,1,248,23,196,1,251,22,144,7,2,23,23,199,1,28,248,22,73,23, +203,2,87,94,23,202,1,23,201,1,250,22,1,22,160,13,23,204,1,23,205, +1,23,198,1,27,249,22,160,13,248,22,66,23,202,2,23,199,2,28,248,22, +155,13,23,194,2,27,250,22,1,22,160,13,23,197,1,23,202,2,28,248,22, +155,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22, +73,23,194,2,87,94,23,193,1,248,23,199,1,251,22,144,7,2,23,23,202, +1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,160, +13,23,207,1,23,208,1,23,201,1,27,249,22,160,13,248,22,66,23,197,2, +23,202,2,28,248,22,155,13,23,194,2,27,250,22,1,22,160,13,23,197,1, +204,28,248,22,155,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201, 253,2,37,202,203,204,205,206,248,22,67,200,87,94,23,193,1,27,248,22,67, 23,201,1,28,248,22,73,23,194,2,87,94,23,193,1,248,23,198,1,251,22, -143,7,2,23,23,201,1,28,248,22,73,23,205,2,87,94,23,204,1,23,203, -1,250,22,1,22,159,13,23,206,1,23,207,1,23,200,1,27,249,22,159,13, -248,22,66,23,197,2,23,201,2,28,248,22,154,13,23,194,2,27,250,22,1, -22,159,13,23,197,1,203,28,248,22,154,13,193,192,253,2,37,202,203,204,205, -206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,182, -13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,142,13,23,194,2, -10,27,248,22,141,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, -22,159,6,23,195,2,27,248,22,163,13,23,196,2,28,23,193,2,192,87,94, -23,193,1,248,22,164,13,23,196,2,11,12,252,22,132,9,23,200,2,2,24, -35,23,198,2,23,199,2,28,28,248,22,159,6,23,195,2,10,248,22,147,7, -23,195,2,87,94,23,194,1,12,252,22,132,9,23,200,2,2,25,36,23,198, -2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,162,13,23,197,2,87, -94,23,195,1,87,94,28,192,12,250,22,133,9,23,201,1,2,26,23,199,1, -249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,142, -13,23,196,2,10,27,248,22,141,13,23,197,2,28,23,193,2,192,87,94,23, -193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,198,2,28,23,193, -2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,12,252,22,132,9,2, -9,2,24,35,23,200,2,23,201,2,28,28,248,22,159,6,23,197,2,10,248, -22,147,7,23,197,2,12,252,22,132,9,2,9,2,25,36,23,200,2,23,201, -2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199,2,87,94,23,195, -1,87,94,28,192,12,250,22,133,9,2,9,2,26,23,201,2,249,22,7,194, -195,27,249,22,151,13,250,22,134,14,0,20,35,114,120,35,34,40,63,58,91, -46,93,91,94,46,93,42,124,41,36,34,248,22,147,13,23,201,1,28,248,22, -159,6,23,203,2,249,22,171,7,23,204,1,8,63,23,202,1,28,248,22,142, -13,23,199,2,248,22,143,13,23,199,1,87,94,23,198,1,247,22,144,13,28, -248,22,141,13,194,249,22,159,13,195,194,192,91,159,37,11,90,161,37,35,11, -87,95,28,28,248,22,142,13,23,196,2,10,27,248,22,141,13,23,197,2,28, -23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,163, -13,23,198,2,28,23,193,2,192,87,94,23,193,1,248,22,164,13,23,198,2, -11,12,252,22,132,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22, -159,6,23,197,2,10,248,22,147,7,23,197,2,12,252,22,132,9,2,10,2, -25,36,23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,162,13, -23,199,2,87,94,23,195,1,87,94,28,192,12,250,22,133,9,2,10,2,26, -23,201,2,249,22,7,194,195,27,249,22,151,13,249,22,157,7,250,22,135,14, -0,9,35,114,120,35,34,91,46,93,34,248,22,147,13,23,203,1,6,1,1, -95,28,248,22,159,6,23,202,2,249,22,171,7,23,203,1,8,63,23,201,1, -28,248,22,142,13,23,199,2,248,22,143,13,23,199,1,87,94,23,198,1,247, -22,144,13,28,248,22,141,13,194,249,22,159,13,195,194,192,249,247,22,190,4, -194,11,249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,184,13, -249,80,158,38,47,28,23,195,2,27,248,22,176,7,6,11,11,80,76,84,67, -79,76,76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,196,1, -250,22,159,13,248,22,180,13,69,97,100,100,111,110,45,100,105,114,247,22,174, -7,6,8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,36,250, -22,79,23,203,1,248,22,75,248,22,180,13,72,99,111,108,108,101,99,116,115, -45,100,105,114,23,204,1,28,23,194,2,249,22,65,23,196,1,23,195,1,192, -32,47,89,162,8,44,38,54,2,18,222,33,48,27,249,22,191,13,23,197,2, -23,198,2,28,23,193,2,87,94,23,196,1,27,248,22,90,23,195,2,27,27, -248,22,99,23,197,1,27,249,22,191,13,23,201,2,23,196,2,28,23,193,2, -87,94,23,194,1,27,248,22,90,23,195,2,27,250,2,47,23,203,2,23,204, -1,248,22,99,23,199,1,28,249,22,153,7,23,196,2,2,27,249,22,79,23, -202,2,194,249,22,65,248,22,150,13,23,197,1,23,195,1,87,95,23,199,1, -23,193,1,28,249,22,153,7,23,196,2,2,27,249,22,79,23,200,2,9,249, -22,65,248,22,150,13,23,197,1,9,28,249,22,153,7,23,196,2,2,27,249, -22,79,197,194,87,94,23,196,1,249,22,65,248,22,150,13,23,197,1,194,87, -94,23,193,1,28,249,22,153,7,23,198,2,2,27,249,22,79,195,9,87,94, -23,194,1,249,22,65,248,22,150,13,23,199,1,9,87,95,28,28,248,22,147, -7,194,10,248,22,159,6,194,12,250,22,132,9,2,13,6,21,21,98,121,116, -101,32,115,116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196,28,28, -248,22,74,195,249,22,4,22,141,13,196,11,12,250,22,132,9,2,13,6,13, -13,108,105,115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197,195,28, -248,22,159,6,197,248,22,170,7,197,196,32,50,89,162,8,44,39,57,2,18, -222,33,53,32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101,120,101, -99,222,33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,162,13, -23,199,2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,167,13, -23,201,2,28,249,22,166,8,23,195,2,23,202,2,11,28,248,22,163,13,23, -194,2,250,2,51,23,201,2,23,202,2,249,22,159,13,23,200,2,23,198,1, -250,2,51,23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87,94,23, -193,1,27,28,248,22,141,13,23,196,2,27,249,22,159,13,23,198,2,23,201, -2,28,28,248,22,154,13,193,10,248,22,153,13,193,192,11,11,28,23,193,2, -192,87,94,23,193,1,28,23,199,2,11,27,248,22,167,13,23,202,2,28,249, -22,166,8,23,195,2,23,203,1,11,28,248,22,163,13,23,194,2,250,2,51, -23,202,1,23,203,1,249,22,159,13,23,201,1,23,198,1,250,2,51,201,202, -195,194,28,248,22,73,23,197,2,11,27,248,22,166,13,248,22,66,23,199,2, -27,249,22,159,13,23,196,1,23,197,2,28,248,22,153,13,23,194,2,250,2, -51,198,199,195,87,94,23,193,1,27,248,22,67,23,200,1,28,248,22,73,23, -194,2,11,27,248,22,166,13,248,22,66,23,196,2,27,249,22,159,13,23,196, -1,23,200,2,28,248,22,153,13,23,194,2,250,2,51,201,202,195,87,94,23, -193,1,27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,166, -13,248,22,66,195,27,249,22,159,13,23,196,1,202,28,248,22,153,13,193,250, -2,51,204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22, -141,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,159,6,23, -196,2,27,248,22,163,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248, -22,164,13,23,197,2,11,12,250,22,132,9,2,14,6,25,25,112,97,116,104, -32,111,114,32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117,108,41, -23,197,2,28,28,23,195,2,28,27,248,22,141,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,198, -2,28,23,193,2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,248,22, -163,13,23,196,2,11,10,12,250,22,132,9,2,14,6,29,29,35,102,32,111, -114,32,114,101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32,115,116, -114,105,110,103,23,198,2,28,28,248,22,163,13,23,195,2,91,159,38,11,90, -161,38,35,11,248,22,162,13,23,198,2,249,22,164,8,194,68,114,101,108,97, -116,105,118,101,11,27,248,22,176,7,6,4,4,80,65,84,72,251,2,50,23, -199,1,23,200,1,23,201,1,28,23,197,2,27,249,80,159,43,47,37,23,200, -1,9,28,249,22,164,8,247,22,178,7,2,20,249,22,65,248,22,150,13,5, -1,46,23,195,1,192,9,27,248,22,166,13,23,196,1,28,248,22,153,13,193, -250,2,51,198,199,195,11,250,80,158,38,48,196,197,11,250,80,158,38,48,196, -11,11,87,94,249,22,150,6,247,22,186,4,195,248,22,176,5,249,22,172,3, -35,249,22,156,3,197,198,27,28,23,197,2,87,95,23,196,1,23,195,1,23, -197,1,87,94,23,197,1,27,248,22,180,13,2,19,27,249,80,159,40,48,37, -23,196,1,11,27,27,248,22,175,3,23,200,1,28,192,192,35,27,27,248,22, -175,3,23,202,1,28,192,192,35,249,22,153,5,23,197,1,83,158,39,20,97, -95,89,162,8,44,35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248, -22,138,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1, -11,16,0,83,158,41,20,100,144,67,35,37,117,116,105,108,115,29,11,11,11, -11,11,10,42,80,158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2, -4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14, -2,15,30,2,17,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105, -111,110,45,107,101,121,4,30,2,17,1,23,101,120,116,101,110,100,45,112,97, -114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,16,0,35,16, -0,35,16,4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11,11,16, -11,2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9, -2,1,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2,6, -2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46,36, -11,11,11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0, -35,35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2,18,223,0,33, -28,80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,18,223,0, -33,29,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,1, -222,33,30,80,159,35,35,36,83,158,35,16,2,249,22,161,6,7,92,7,92, -80,159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,3,223,0,33,31, -80,159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,4,222, -33,32,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2, -5,222,33,34,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2, -6,223,0,33,36,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39, -51,2,7,222,33,39,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43, -38,49,2,8,222,33,40,80,159,35,42,36,83,158,35,16,2,32,0,89,162, -43,37,52,2,9,222,33,41,80,159,35,43,36,83,158,35,16,2,32,0,89, -162,43,37,53,2,10,222,33,42,80,159,35,44,36,83,158,35,16,2,32,0, -89,162,43,36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83, -158,38,20,96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36, -44,9,223,0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36, -83,158,35,16,2,27,248,22,187,13,248,22,170,7,27,28,249,22,164,8,247, -22,178,7,2,20,6,1,1,59,6,1,1,58,250,22,143,7,6,14,14,40, -91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162, -8,44,37,47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83, -158,38,20,96,96,2,14,89,162,8,44,38,53,9,223,0,33,54,89,162,43, -37,46,9,223,0,33,55,89,162,43,36,45,9,223,0,33,56,80,159,35,48, -36,83,158,35,16,2,89,162,43,38,51,2,15,223,0,33,58,80,159,35,49, -36,94,29,94,2,16,68,35,37,107,101,114,110,101,108,11,29,94,2,16,69, -35,37,109,105,110,45,115,116,120,11,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 5012); +144,7,2,23,23,201,1,28,248,22,73,23,205,2,87,94,23,204,1,23,203, +1,250,22,1,22,160,13,23,206,1,23,207,1,23,200,1,27,249,22,160,13, +248,22,66,23,197,2,23,201,2,28,248,22,155,13,23,194,2,27,250,22,1, +22,160,13,23,197,1,203,28,248,22,155,13,193,192,253,2,37,202,203,204,205, +206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,183, +13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,143,13,23,194,2, +10,27,248,22,142,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, +22,160,6,23,195,2,27,248,22,164,13,23,196,2,28,23,193,2,192,87,94, +23,193,1,248,22,165,13,23,196,2,11,12,252,22,133,9,23,200,2,2,24, +35,23,198,2,23,199,2,28,28,248,22,160,6,23,195,2,10,248,22,148,7, +23,195,2,87,94,23,194,1,12,252,22,133,9,23,200,2,2,25,36,23,198, +2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,163,13,23,197,2,87, +94,23,195,1,87,94,28,192,12,250,22,134,9,23,201,1,2,26,23,199,1, +249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,143, +13,23,196,2,10,27,248,22,142,13,23,197,2,28,23,193,2,192,87,94,23, +193,1,28,248,22,160,6,23,197,2,27,248,22,164,13,23,198,2,28,23,193, +2,192,87,94,23,193,1,248,22,165,13,23,198,2,11,12,252,22,133,9,2, +9,2,24,35,23,200,2,23,201,2,28,28,248,22,160,6,23,197,2,10,248, +22,148,7,23,197,2,12,252,22,133,9,2,9,2,25,36,23,200,2,23,201, +2,91,159,38,11,90,161,38,35,11,248,22,163,13,23,199,2,87,94,23,195, +1,87,94,28,192,12,250,22,134,9,2,9,2,26,23,201,2,249,22,7,194, +195,27,249,22,152,13,250,22,135,14,0,20,35,114,120,35,34,40,63,58,91, +46,93,91,94,46,93,42,124,41,36,34,248,22,148,13,23,201,1,28,248,22, +160,6,23,203,2,249,22,172,7,23,204,1,8,63,23,202,1,28,248,22,143, +13,23,199,2,248,22,144,13,23,199,1,87,94,23,198,1,247,22,145,13,28, +248,22,142,13,194,249,22,160,13,195,194,192,91,159,37,11,90,161,37,35,11, +87,95,28,28,248,22,143,13,23,196,2,10,27,248,22,142,13,23,197,2,28, +23,193,2,192,87,94,23,193,1,28,248,22,160,6,23,197,2,27,248,22,164, +13,23,198,2,28,23,193,2,192,87,94,23,193,1,248,22,165,13,23,198,2, +11,12,252,22,133,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22, +160,6,23,197,2,10,248,22,148,7,23,197,2,12,252,22,133,9,2,10,2, +25,36,23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,163,13, +23,199,2,87,94,23,195,1,87,94,28,192,12,250,22,134,9,2,10,2,26, +23,201,2,249,22,7,194,195,27,249,22,152,13,249,22,158,7,250,22,136,14, +0,9,35,114,120,35,34,91,46,93,34,248,22,148,13,23,203,1,6,1,1, +95,28,248,22,160,6,23,202,2,249,22,172,7,23,203,1,8,63,23,201,1, +28,248,22,143,13,23,199,2,248,22,144,13,23,199,1,87,94,23,198,1,247, +22,145,13,28,248,22,142,13,194,249,22,160,13,195,194,192,249,247,22,191,4, +194,11,249,80,159,37,46,36,9,9,249,80,159,37,46,36,195,9,27,247,22, +185,13,249,80,158,38,47,28,23,195,2,27,248,22,177,7,6,11,11,80,76, +84,67,79,76,76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23, +196,1,250,22,160,13,248,22,181,13,69,97,100,100,111,110,45,100,105,114,247, +22,175,7,6,8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52, +36,250,22,79,23,203,1,248,22,75,248,22,181,13,72,99,111,108,108,101,99, +116,115,45,100,105,114,23,204,1,28,23,194,2,249,22,65,23,196,1,23,195, +1,192,32,47,89,162,8,44,38,54,2,18,222,33,48,27,249,22,128,14,23, +197,2,23,198,2,28,23,193,2,87,94,23,196,1,27,248,22,90,23,195,2, +27,27,248,22,99,23,197,1,27,249,22,128,14,23,201,2,23,196,2,28,23, +193,2,87,94,23,194,1,27,248,22,90,23,195,2,27,250,2,47,23,203,2, +23,204,1,248,22,99,23,199,1,28,249,22,154,7,23,196,2,2,27,249,22, +79,23,202,2,194,249,22,65,248,22,151,13,23,197,1,23,195,1,87,95,23, +199,1,23,193,1,28,249,22,154,7,23,196,2,2,27,249,22,79,23,200,2, +9,249,22,65,248,22,151,13,23,197,1,9,28,249,22,154,7,23,196,2,2, +27,249,22,79,197,194,87,94,23,196,1,249,22,65,248,22,151,13,23,197,1, +194,87,94,23,193,1,28,249,22,154,7,23,198,2,2,27,249,22,79,195,9, +87,94,23,194,1,249,22,65,248,22,151,13,23,199,1,9,87,95,28,28,248, +22,148,7,194,10,248,22,160,6,194,12,250,22,133,9,2,13,6,21,21,98, +121,116,101,32,115,116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196, +28,28,248,22,74,195,249,22,4,22,142,13,196,11,12,250,22,133,9,2,13, +6,13,13,108,105,115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197, +195,28,248,22,160,6,197,248,22,171,7,197,196,32,50,89,162,8,44,39,57, +2,18,222,33,53,32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101, +120,101,99,222,33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22, +163,13,23,199,2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22, +168,13,23,201,2,28,249,22,167,8,23,195,2,23,202,2,11,28,248,22,164, +13,23,194,2,250,2,51,23,201,2,23,202,2,249,22,160,13,23,200,2,23, +198,1,250,2,51,23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87, +94,23,193,1,27,28,248,22,142,13,23,196,2,27,249,22,160,13,23,198,2, +23,201,2,28,28,248,22,155,13,193,10,248,22,154,13,193,192,11,11,28,23, +193,2,192,87,94,23,193,1,28,23,199,2,11,27,248,22,168,13,23,202,2, +28,249,22,167,8,23,195,2,23,203,1,11,28,248,22,164,13,23,194,2,250, +2,51,23,202,1,23,203,1,249,22,160,13,23,201,1,23,198,1,250,2,51, +201,202,195,194,28,248,22,73,23,197,2,11,27,248,22,167,13,248,22,66,23, +199,2,27,249,22,160,13,23,196,1,23,197,2,28,248,22,154,13,23,194,2, +250,2,51,198,199,195,87,94,23,193,1,27,248,22,67,23,200,1,28,248,22, +73,23,194,2,11,27,248,22,167,13,248,22,66,23,196,2,27,249,22,160,13, +23,196,1,23,200,2,28,248,22,154,13,23,194,2,250,2,51,201,202,195,87, +94,23,193,1,27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248, +22,167,13,248,22,66,195,27,249,22,160,13,23,196,1,202,28,248,22,154,13, +193,250,2,51,204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27, +248,22,142,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,160, +6,23,196,2,27,248,22,164,13,23,197,2,28,23,193,2,192,87,94,23,193, +1,248,22,165,13,23,197,2,11,12,250,22,133,9,2,14,6,25,25,112,97, +116,104,32,111,114,32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117, +108,41,23,197,2,28,28,23,195,2,28,27,248,22,142,13,23,197,2,28,23, +193,2,192,87,94,23,193,1,28,248,22,160,6,23,197,2,27,248,22,164,13, +23,198,2,28,23,193,2,192,87,94,23,193,1,248,22,165,13,23,198,2,11, +248,22,164,13,23,196,2,11,10,12,250,22,133,9,2,14,6,29,29,35,102, +32,111,114,32,114,101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32, +115,116,114,105,110,103,23,198,2,28,28,248,22,164,13,23,195,2,91,159,38, +11,90,161,38,35,11,248,22,163,13,23,198,2,249,22,165,8,194,68,114,101, +108,97,116,105,118,101,11,27,248,22,177,7,6,4,4,80,65,84,72,251,2, +50,23,199,1,23,200,1,23,201,1,28,23,197,2,27,249,80,159,43,47,37, +23,200,1,9,28,249,22,165,8,247,22,179,7,2,20,249,22,65,248,22,151, +13,5,1,46,23,195,1,192,9,27,248,22,167,13,23,196,1,28,248,22,154, +13,193,250,2,51,198,199,195,11,250,80,159,38,48,36,196,197,11,250,80,159, +38,48,36,196,11,11,87,94,249,22,151,6,247,22,187,4,195,248,22,177,5, +249,22,172,3,35,249,22,156,3,197,198,27,28,23,197,2,87,95,23,196,1, +23,195,1,23,197,1,87,94,23,197,1,27,248,22,181,13,2,19,27,249,80, +159,40,48,36,23,196,1,11,27,27,248,22,175,3,23,200,1,28,192,192,35, +27,27,248,22,175,3,23,202,1,28,192,192,35,249,22,154,5,23,197,1,83, +158,39,20,97,95,89,162,8,44,35,47,9,224,3,2,33,57,23,195,1,23, +196,1,27,248,22,139,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103, +159,35,16,1,11,16,0,83,158,41,20,100,144,67,35,37,117,116,105,108,115, +29,11,11,11,11,11,10,42,80,158,35,35,20,103,159,37,16,17,2,1,2, +2,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12, +2,13,2,14,2,15,30,2,17,1,20,112,97,114,97,109,101,116,101,114,105, +122,97,116,105,111,110,45,107,101,121,4,30,2,17,1,23,101,120,116,101,110, +100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0, +16,0,35,16,0,35,16,4,2,5,2,4,2,2,2,8,39,11,11,38,35, +11,11,11,16,11,2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10, +2,13,2,9,2,1,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11, +2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2, +1,46,46,36,11,11,11,16,0,16,0,16,0,35,35,11,11,11,11,16,0, +16,0,16,0,35,35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2, +18,223,0,33,28,80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55, +2,18,223,0,33,29,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43, +36,44,2,1,222,33,30,80,159,35,35,36,83,158,35,16,2,249,22,162,6, +7,92,7,92,80,159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,3, +223,0,33,31,80,159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37, +49,2,4,222,33,32,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8, +44,38,50,2,5,222,33,34,80,159,35,39,36,83,158,35,16,2,89,162,8, +45,37,47,2,6,223,0,33,36,80,159,35,40,36,83,158,35,16,2,32,0, +89,162,43,39,51,2,7,222,33,39,80,159,35,41,36,83,158,35,16,2,32, +0,89,162,43,38,49,2,8,222,33,40,80,159,35,42,36,83,158,35,16,2, +32,0,89,162,43,37,52,2,9,222,33,41,80,159,35,43,36,83,158,35,16, +2,32,0,89,162,43,37,53,2,10,222,33,42,80,159,35,44,36,83,158,35, +16,2,32,0,89,162,43,36,43,2,11,222,33,43,80,159,35,45,36,83,158, +35,16,2,83,158,38,20,96,96,2,12,89,162,43,35,43,9,223,0,33,44, +89,162,43,36,44,9,223,0,33,45,89,162,43,37,54,9,223,0,33,46,80, +159,35,46,36,83,158,35,16,2,27,248,22,188,13,248,22,171,7,27,28,249, +22,165,8,247,22,179,7,2,20,6,1,1,59,6,1,1,58,250,22,144,7, +6,14,14,40,91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23, +196,1,89,162,8,44,37,47,2,13,223,0,33,49,80,159,35,47,36,83,158, +35,16,2,83,158,38,20,96,96,2,14,89,162,8,44,38,53,9,223,0,33, +54,89,162,43,37,46,9,223,0,33,55,89,162,43,36,45,9,223,0,33,56, +80,159,35,48,36,83,158,35,16,2,89,162,43,38,51,2,15,223,0,33,58, +80,159,35,49,36,94,29,94,2,16,68,35,37,107,101,114,110,101,108,11,29, +94,2,16,69,35,37,109,105,110,45,115,116,120,11,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 5016); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,54,8,0,0,0,1,0,0,6,0,19,0, 34,0,48,0,62,0,76,0,115,0,0,0,6,1,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, -37,107,101,114,110,101,108,11,97,35,11,8,174,230,98,159,2,2,35,35,159, +37,107,101,114,110,101,108,11,97,35,11,8,142,234,98,159,2,2,35,35,159, 2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,159,2, 6,35,35,16,0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100, 144,69,35,37,98,117,105,108,116,105,110,29,11,11,11,11,11,18,96,11,42, @@ -360,7 +360,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 299); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,52,0,0,0,1,0,0,11,0,38,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,54,52,0,0,0,1,0,0,11,0,38,0, 44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220, 0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1, 89,1,192,1,237,1,1,2,30,2,61,2,117,2,127,2,174,2,184,2,191, @@ -382,32 +382,32 @@ 110,97,116,105,118,101,64,108,111,111,112,1,29,115,116,97,110,100,97,114,100, 45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114, 63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37, -249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,164,8,23,197,2, -80,158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,173,4,23,197,2, -28,248,22,141,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,162,13, +249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,165,8,23,197,2, +80,158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,174,4,23,197,2, +28,248,22,142,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,163,13, 23,197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40, -47,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,191,4,28, -192,192,247,22,181,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27, -11,80,158,40,39,22,191,4,28,248,22,141,13,23,198,2,23,197,1,87,94, -23,197,1,247,22,181,13,247,194,250,22,159,13,23,197,1,23,199,1,249,80, -158,42,38,23,198,1,2,17,252,22,159,13,23,199,1,23,201,1,2,18,247, -22,179,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1, -27,250,22,176,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249, -22,65,195,194,11,27,252,22,159,13,23,200,1,23,202,1,2,18,247,22,179, -7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,176,13,196,11, +47,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,128,5,28, +192,192,247,22,182,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27, +11,80,158,40,39,22,128,5,28,248,22,142,13,23,198,2,23,197,1,87,94, +23,197,1,247,22,182,13,247,194,250,22,160,13,23,197,1,23,199,1,249,80, +158,42,38,23,198,1,2,17,252,22,160,13,23,199,1,23,201,1,2,18,247, +22,180,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1, +27,250,22,177,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249, +22,65,195,194,11,27,252,22,160,13,23,200,1,23,202,1,2,18,247,22,180, +7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,177,13,196,11, 32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247, -22,186,13,248,22,66,195,195,27,250,22,159,13,23,198,1,23,200,1,249,80, -158,43,38,23,199,1,2,17,27,250,22,176,13,196,11,32,0,89,162,8,44, -35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,189,4,248,22,66, -195,195,249,247,22,189,4,194,195,87,94,28,248,80,158,36,37,23,195,2,12, -250,22,132,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101, +22,187,13,248,22,66,195,195,27,250,22,160,13,23,198,1,23,200,1,249,80, +158,43,38,23,199,1,2,17,27,250,22,177,13,196,11,32,0,89,162,8,44, +35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,190,4,248,22,66, +195,195,249,247,22,190,4,194,195,87,94,28,248,80,158,36,37,23,195,2,12, +250,22,133,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101, 100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116, 104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28, -248,22,165,13,23,201,2,23,200,1,27,247,22,191,4,28,23,193,2,249,22, -166,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,162,13,23,194,2, -87,94,23,196,1,90,161,36,39,11,28,249,22,164,8,23,196,2,68,114,101, +248,22,166,13,23,201,2,23,200,1,27,247,22,128,5,28,23,193,2,249,22, +167,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,163,13,23,194,2, +87,94,23,196,1,90,161,36,39,11,28,249,22,165,8,23,196,2,68,114,101, 108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90,161,36,40,11, -247,22,183,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89, +247,22,184,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89, 162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44,36,46, 9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44, 36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2,11,193,28,192, @@ -420,10 +420,10 @@ 203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54,36,203,89,162, 43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54,2,19,222,33, 38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27, -249,22,191,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65, -248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,191,13,2,37,23, +249,22,128,14,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65, +248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,128,14,2,37,23, 196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,27, -248,22,99,23,197,1,27,249,22,191,13,2,37,23,196,2,28,23,193,2,87, +248,22,99,23,197,1,27,249,22,128,14,2,37,23,196,2,28,23,193,2,87, 94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248,22,99,23,197, 1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162,43,36,54,2, 19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66, @@ -434,97 +434,97 @@ 23,197,2,249,22,7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22, 7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22,7,249,22,65,248, 22,66,23,200,1,23,197,1,195,27,248,2,36,23,195,1,28,194,192,248,2, -39,193,87,95,28,248,22,171,4,195,12,250,22,132,9,2,20,6,20,20,114, +39,193,87,95,28,248,22,172,4,195,12,250,22,133,9,2,20,6,20,20,114, 101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,197,28, 24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,139,2,80, -159,41,42,37,248,22,147,14,247,22,188,11,11,28,23,193,2,192,87,94,23, -193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,248,22,147,14, -247,22,188,11,195,192,250,22,137,2,195,198,66,97,116,116,97,99,104,251,211, -197,198,199,10,28,192,250,22,131,9,11,196,195,248,22,129,9,194,28,249,22, -165,6,194,6,1,1,46,2,16,28,249,22,165,6,194,6,2,2,46,46,62, -117,112,192,28,249,22,166,8,248,22,67,23,200,2,23,197,1,28,249,22,164, -8,248,22,66,23,200,2,23,196,1,251,22,129,9,2,20,6,26,26,99,121, +159,41,42,37,248,22,148,14,247,22,189,11,11,28,23,193,2,192,87,94,23, +193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,248,22,148,14, +247,22,189,11,195,192,250,22,137,2,195,198,66,97,116,116,97,99,104,251,211, +197,198,199,10,28,192,250,22,132,9,11,196,195,248,22,130,9,194,28,249,22, +166,6,194,6,1,1,46,2,16,28,249,22,166,6,194,6,2,2,46,46,62, +117,112,192,28,249,22,167,8,248,22,67,23,200,2,23,197,1,28,249,22,165, +8,248,22,66,23,200,2,23,196,1,251,22,130,9,2,20,6,26,26,99,121, 99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58, 32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65,23,206,1,23, -202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,248,22,147,14, -247,22,188,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22, -27,11,80,158,44,39,22,153,4,23,196,1,249,247,22,190,4,23,198,1,248, -22,54,248,22,145,13,23,198,1,87,94,28,28,248,22,141,13,23,197,2,10, -248,22,177,4,23,197,2,12,28,23,198,2,250,22,131,9,11,6,15,15,98, -97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,250,22,132,9, +202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,248,22,148,14, +247,22,189,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22, +27,11,80,158,44,39,22,154,4,23,196,1,249,247,22,191,4,23,198,1,248, +22,54,248,22,146,13,23,198,1,87,94,28,28,248,22,142,13,23,197,2,10, +248,22,178,4,23,197,2,12,28,23,198,2,250,22,132,9,11,6,15,15,98, +97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,250,22,133,9, 2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,32,112, -97,116,104,23,199,2,28,28,248,22,63,23,197,2,249,22,164,8,248,22,66, -23,199,2,2,3,11,248,22,172,4,248,22,90,197,28,28,248,22,63,23,197, -2,249,22,164,8,248,22,66,23,199,2,66,112,108,97,110,101,116,11,87,94, +97,116,104,23,199,2,28,28,248,22,63,23,197,2,249,22,165,8,248,22,66, +23,199,2,2,3,11,248,22,173,4,248,22,90,197,28,28,248,22,63,23,197, +2,249,22,165,8,248,22,66,23,199,2,66,112,108,97,110,101,116,11,87,94, 28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22,27,11,80,158, -42,39,22,188,11,23,197,1,90,161,36,35,10,249,22,154,4,21,94,2,21, +42,39,22,189,11,23,197,1,90,161,36,35,10,249,22,155,4,21,94,2,21, 6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,115,115, 1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45, 114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94,23,193,1,27, 89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101,99,116,105,111, 110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2,27,250,22,139, -2,80,159,43,43,37,249,22,65,23,204,2,247,22,182,13,11,28,23,193,2, +2,80,159,43,43,37,249,22,65,23,204,2,247,22,183,13,11,28,23,193,2, 192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44,48,36, 248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202,1,28,248,22, 73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73,23,199,2,9, -248,22,67,23,199,2,249,22,159,13,23,195,1,28,248,22,73,23,197,1,87, -94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,182,6,23,199,1, -6,3,3,46,115,115,28,248,22,159,6,23,199,2,87,94,23,194,1,27,248, +248,22,67,23,199,2,249,22,160,13,23,195,1,28,248,22,73,23,197,1,87, +94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,183,6,23,199,1, +6,3,3,46,115,115,28,248,22,160,6,23,199,2,87,94,23,194,1,27,248, 80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43,37,249,22,65, 23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11, -90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,159,13, +90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,160,13, 23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43,9,222,33,45, -23,200,1,248,22,75,23,200,1,28,248,22,141,13,23,199,2,87,94,23,194, -1,28,248,22,164,13,23,199,2,23,198,2,248,22,75,6,26,26,32,40,97, +23,200,1,248,22,75,23,200,1,28,248,22,142,13,23,199,2,87,94,23,194, +1,28,248,22,165,13,23,199,2,23,198,2,248,22,75,6,26,26,32,40,97, 32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115,111,108,117,116, -101,41,28,249,22,164,8,248,22,66,23,201,2,2,21,27,250,22,139,2,80, -159,43,43,37,249,22,65,23,204,2,247,22,182,13,11,28,23,193,2,192,87, +101,41,28,249,22,165,8,248,22,66,23,201,2,2,21,27,250,22,139,2,80, +159,43,43,37,249,22,65,23,204,2,247,22,183,13,11,28,23,193,2,192,87, 94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45,48,36,248,22, 90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92,23,204,2,28, -248,22,73,23,194,2,249,22,129,14,0,8,35,114,120,34,91,46,93,34,23, +248,22,73,23,194,2,249,22,130,14,0,8,35,114,120,34,91,46,93,34,23, 196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73,248,22,92,23, 208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79,249,22,2,80, 159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73,23,196,2,248, 22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204,1,248,22,66, -23,198,2,248,22,67,23,198,1,249,22,159,13,23,195,1,28,23,198,1,87, +23,198,2,248,22,67,23,198,1,249,22,160,13,23,195,1,28,23,198,1,87, 94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23,197,1,6,7, -7,109,97,105,110,46,115,115,28,249,22,129,14,0,8,35,114,120,34,91,46, -93,34,23,199,2,23,197,1,249,22,182,6,23,199,1,6,3,3,46,115,115, -28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249,22,166,13,248, -22,170,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94, -28,28,248,22,141,13,23,194,2,10,248,22,181,7,23,194,2,87,94,23,200, -1,12,28,23,200,2,250,22,131,9,67,114,101,113,117,105,114,101,249,22,143, +7,109,97,105,110,46,115,115,28,249,22,130,14,0,8,35,114,120,34,91,46, +93,34,23,199,2,23,197,1,249,22,183,6,23,199,1,6,3,3,46,115,115, +28,249,22,165,8,248,22,66,23,201,2,64,102,105,108,101,249,22,167,13,248, +22,171,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94, +28,28,248,22,142,13,23,194,2,10,248,22,182,7,23,194,2,87,94,23,200, +1,12,28,23,200,2,250,22,132,9,67,114,101,113,117,105,114,101,249,22,144, 7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97, 28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87,94,23,200,1, -250,22,132,9,2,20,249,22,143,7,6,13,13,109,111,100,117,108,101,32,112, +250,22,133,9,2,20,249,22,144,7,6,13,13,109,111,100,117,108,101,32,112, 97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,201,2, -27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35,249,22,168,13, -248,22,169,13,23,197,2,11,27,28,248,22,181,7,23,196,2,249,22,186,7, +27,28,248,22,182,7,23,195,2,249,22,187,7,23,196,2,35,249,22,169,13, +248,22,170,13,23,197,2,11,27,28,248,22,182,7,23,196,2,249,22,187,7, 23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90,161,38,35,11, -28,248,22,181,7,23,199,2,250,22,7,2,22,249,22,186,7,23,203,2,37, -2,22,248,22,162,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22, -181,7,23,200,2,249,22,186,7,23,201,2,38,249,80,158,47,52,23,197,2, -5,0,27,28,248,22,181,7,23,201,2,249,22,186,7,23,202,2,39,248,22, -172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,22,147,14,247, -22,188,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,123,87,94,250, -22,137,2,80,159,52,42,37,248,22,147,14,247,22,188,11,195,192,87,95,28, +28,248,22,182,7,23,199,2,250,22,7,2,22,249,22,187,7,23,203,2,37, +2,22,248,22,163,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22, +182,7,23,200,2,249,22,187,7,23,201,2,38,249,80,158,47,52,23,197,2, +5,0,27,28,248,22,182,7,23,201,2,249,22,187,7,23,202,2,39,248,22, +173,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,22,148,14,247, +22,189,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,123,87,94,250, +22,137,2,80,159,52,42,37,248,22,148,14,247,22,189,11,195,192,87,95,28, 23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1,12,87,95,27, 27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22,19,250,22,25, -248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,147,14,247,22, -188,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9,226,12,11, +248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,148,14,247,22, +189,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9,226,12,11, 2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159,50,45,37,32, 0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162,43,35,50,9, 227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10,12,28,28,248, -22,181,7,23,202,1,11,27,248,22,159,6,23,208,2,28,192,192,27,248,22, -53,23,209,2,28,192,192,28,248,22,63,23,209,2,249,22,164,8,248,22,66, -23,211,2,2,21,11,250,22,137,2,80,159,50,43,37,28,248,22,159,6,23, +22,182,7,23,202,1,11,27,248,22,160,6,23,208,2,28,192,192,27,248,22, +53,23,209,2,28,192,192,28,248,22,63,23,209,2,249,22,165,8,248,22,66, +23,211,2,2,21,11,250,22,137,2,80,159,50,43,37,28,248,22,160,6,23, 210,2,249,22,65,23,211,1,248,80,159,53,55,36,23,213,1,87,94,23,210, -1,249,22,65,23,211,1,247,22,182,13,252,22,183,7,23,208,1,23,207,1, +1,249,22,65,23,211,1,247,22,183,13,252,22,184,7,23,208,1,23,207,1, 23,205,1,23,203,1,201,12,193,91,159,37,10,90,161,36,35,10,11,90,161, 36,36,10,83,158,38,20,96,96,2,20,89,162,8,44,36,50,9,224,2,0, 33,42,89,162,43,38,48,9,223,1,33,43,89,162,43,39,8,30,9,225,2, -3,0,33,49,208,87,95,248,22,152,4,248,80,159,37,49,37,247,22,188,11, -248,22,190,4,80,159,36,36,37,248,22,179,12,80,159,36,41,36,159,35,20, +3,0,33,49,208,87,95,248,22,153,4,248,80,159,37,49,36,247,22,189,11, +248,22,191,4,80,159,36,36,36,248,22,180,12,80,159,36,41,36,159,35,20, 103,159,35,16,1,11,16,0,83,158,41,20,100,144,66,35,37,98,111,111,116, 29,11,11,11,11,11,10,36,80,158,35,35,20,103,159,39,16,19,2,1,2, 2,30,2,4,72,112,97,116,104,45,115,116,114,105,110,103,63,10,30,2,4, @@ -543,7 +543,7 @@ 83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,56,36,83, 158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,25, 80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45, -100,105,114,223,0,33,26,80,159,35,54,36,83,158,35,16,2,248,22,178,7, +100,105,114,223,0,33,26,80,159,35,54,36,83,158,35,16,2,248,22,179,7, 69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89, 162,43,37,59,2,2,223,0,33,35,80,159,35,36,36,83,158,35,16,2,32, 0,89,162,8,44,36,41,2,6,222,192,80,159,35,41,36,83,158,35,16,2, diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 221c02b906..314fa2237a 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -9366,12 +9366,16 @@ static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *rena Scheme_Object *rl = renaming; if (SCHEME_PAIRP(renaming)) { - l = scheme_add_rib_delimiter(l, scheme_null); + int need_delim; + need_delim = !SCHEME_NULLP(SCHEME_CDR(rl)); + if (need_delim) + l = scheme_add_rib_delimiter(l, scheme_null); while (!SCHEME_NULLP(rl)) { l = scheme_add_rename(l, SCHEME_CAR(rl)); rl = SCHEME_CDR(rl); } - l = scheme_add_rib_delimiter(l, renaming); + if (need_delim) + l = scheme_add_rib_delimiter(l, renaming); } else { l = scheme_add_rename(l, renaming); } diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 4cc990480e..146b1454bc 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -2734,7 +2734,9 @@ Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o) rmp->type = scheme_resolved_module_path_type; SCHEME_PTR_VAL(rmp) = o; + scheme_start_atomic(); b = scheme_bucket_from_table(modpath_table, (const char *)rmp); + scheme_end_atomic_no_swap(); if (!b->val) b->val = scheme_true; @@ -9151,6 +9153,7 @@ top_level_require_execute(Scheme_Object *data) { do_require_execute(scheme_environment_from_dummy(SCHEME_CAR(data)), SCHEME_CDR(data)); + return scheme_void; } static Scheme_Object * diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 519ede6b74..6ab0b63fb6 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 950 +#define EXPECTED_PRIM_COUNT 951 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 675708fc7a..bde6b08906 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.2.0.1" +#define MZSCHEME_VERSION "4.2.0.2" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 1 +#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 7f555aff10..c719a54981 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -65,6 +65,7 @@ static Scheme_Object *module_binding(int argc, Scheme_Object **argv); static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv); static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv); static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv); +static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv); static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv); static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv); @@ -100,6 +101,8 @@ static THREAD_LOCAL Scheme_Object *unsealed_dependencies; static THREAD_LOCAL Scheme_Hash_Table *id_marks_ht; /* a cache */ static THREAD_LOCAL Scheme_Hash_Table *than_id_marks_ht; /* a cache */ +static Scheme_Bucket_Table *interned_skip_ribs; /* FIXME: shared among threads */ + static Scheme_Object *no_nested_inactive_certs; #ifdef MZ_PRECISE_GC @@ -222,6 +225,18 @@ static Module_Renames *krn; #define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) #define SCHEME_RIB_DELIMP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rib_delimiter_type)) +#define SCHEME_PRUNEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_prune_context_type)) + +XFORM_NONGCING static int is_member(Scheme_Object *a, Scheme_Object *l) +{ + while (SCHEME_PAIRP(l)) { + if (SAME_OBJ(a, SCHEME_CAR(l))) + return 1; + l = SCHEME_CDR(l); + } + return 0; +} + static int is_rename_inspector_info(Scheme_Object *v) { return (SAME_TYPE(SCHEME_TYPE(v), scheme_inspector_type) @@ -277,6 +292,10 @@ static int is_rename_inspector_info(Scheme_Object *v) when given a list of ribs, and simplifcation eliminates rib delimiters + - A wrap-elem (make-prune ) + restricts binding information to that relevant for + as a datum + - A wrap-elem is a module rename set the hash table maps renamed syms to modname-srcname pairs @@ -548,6 +567,11 @@ void scheme_init_stx(Scheme_Env *env) "identifier-label-binding", 1, 1), env); + scheme_add_global_constant("identifier-prune-lexical-context", + scheme_make_immed_prim(identifier_prune, + "identifier-prune-lexical-context", + 1, 2), + env); scheme_add_global_constant("syntax-source-module", @@ -610,6 +634,9 @@ void scheme_init_stx(Scheme_Env *env) scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix); scheme_install_type_reader(scheme_free_id_info_type, read_free_id_info_prefix); + + REGISTER_SO(interned_skip_ribs); + interned_skip_ribs = scheme_make_weak_equal_table(); } /*========================================================================*/ @@ -1215,6 +1242,17 @@ Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro) return stx; } +static Scheme_Object *make_prune_context(Scheme_Object *a) +{ + Scheme_Object *p; + + p = scheme_alloc_small_object(); + p->type = scheme_prune_context_type; + SCHEME_BOX_VAL(p) = a; + + return p; +} + /******************** module renames ********************/ static int same_phase(Scheme_Object *a, Scheme_Object *b) @@ -3866,12 +3904,12 @@ static int nonempty_rib(Scheme_Lexical_Rib *rib) static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) { - while (skip_ribs) { - if (SAME_OBJ(SCHEME_CAR(skip_ribs), timestamp)) - return 1; - skip_ribs = SCHEME_CDR(skip_ribs); - } - + if (!skip_ribs) + return 0; + + if (scheme_hash_tree_get((Scheme_Hash_Tree *)skip_ribs, timestamp)) + return 1; + return 0; } @@ -3879,20 +3917,29 @@ static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip { if (in_skip_set(timestamp, skip_ribs)) return skip_ribs; - else - return scheme_make_raw_pair(timestamp, skip_ribs); + + if (!skip_ribs) + skip_ribs = (Scheme_Object *)scheme_make_hash_tree(1); + + skip_ribs = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)skip_ribs, timestamp, scheme_true); + + { + Scheme_Bucket *b; + scheme_start_atomic(); + b = scheme_bucket_from_table(interned_skip_ribs, (const char *)skip_ribs); + scheme_end_atomic_no_swap(); + if (!b->val) + b->val = scheme_true; + + skip_ribs = (Scheme_Object *)HT_EXTRACT_WEAK(b->key); + } + + return skip_ribs; } XFORM_NONGCING static int same_skipped_ribs(Scheme_Object *a, Scheme_Object *b) { - while (a) { - if (!b) return 0; - if (!SAME_OBJ(SCHEME_CAR(a), SCHEME_CAR(b))) - return 0; - a = SCHEME_CDR(a); - b = SCHEME_CDR(b); - } - return !b; + return SAME_OBJ(a, b); } XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, Scheme_Object *skip_ribs) @@ -3913,8 +3960,9 @@ XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, if (SCHEME_RPAIRP(other_env)) { while (other_env) { p = SCHEME_CAR(other_env); - if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) + if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) { return SCHEME_CDR(p); + } other_env = SCHEME_CDR(other_env); } return scheme_void; @@ -3978,6 +4026,36 @@ static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *othe return orig; } +static void extract_lex_range(Scheme_Object *rename, Scheme_Object *a, int *_istart, int *_iend) +{ + int istart, iend, c; + + c = SCHEME_RENAME_LEN(rename); + + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { + void *pos; + pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), a); + if (pos) { + istart = SCHEME_INT_VAL(pos); + if (istart < 0) { + /* -1 indicates multiple slots matching this name. */ + istart = 0; + iend = c; + } else + iend = istart + 1; + } else { + istart = 0; + iend = 0; + } + } else { + istart = 0; + iend = c; + } + + *_istart = istart; + *_iend = iend; +} + /* This needs to be a multiple of 4: */ #define QUICK_STACK_SIZE 16 @@ -4426,6 +4504,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else { rename = WRAP_POS_FIRST(wraps); is_rib = NULL; + did_rib = NULL; } EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0, @@ -4436,25 +4515,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, c = SCHEME_RENAME_LEN(rename); /* Get index from hash table, if there is one: */ - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { - void *pos; - pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), SCHEME_STX_VAL(a)); - if (pos) { - istart = SCHEME_INT_VAL(pos); - if (istart < 0) { - /* -1 indicates multiple slots matching this name. */ - istart = 0; - iend = c; - } else - iend = istart + 1; - } else { - istart = 0; - iend = 0; - } - } else { - istart = 0; - iend = c; - } + extract_lex_range(rename, SCHEME_STX_VAL(a), &istart, &iend); for (ri = istart; ri < iend; ri++) { renamed = SCHEME_VEC_ELS(rename)[2+ri]; @@ -4591,6 +4652,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, rib_delim = WRAP_POS_FIRST(wraps); if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) rib_delim = scheme_false; + did_rib = NULL; } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps))); did_rib = NULL; @@ -4613,6 +4675,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, continue; /* <<<<< ------ */ } + } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) { + if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) { + /* Doesn't match pruned-to sym; already produce #f */ + return scheme_false; + } } if (!rib) @@ -4859,6 +4926,11 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ } } } while (rib); + } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) { + if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) { + /* Doesn't match pruned-to sym, so no binding */ + return SCHEME_STX_VAL(a); + } } /* Keep looking: */ @@ -5001,8 +5073,8 @@ int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) Scheme_Object *m1, *m2, *skips = NULL; while (SCHEME_PAIRP(skip_ribs)) { - skips = scheme_make_raw_pair(((Scheme_Lexical_Rib *)SCHEME_CAR(skip_ribs))->timestamp, - skips); + skips = add_skip_set(((Scheme_Lexical_Rib *)SCHEME_CAR(skip_ribs))->timestamp, + skips); skip_ribs = SCHEME_CDR(skip_ribs); } @@ -5521,15 +5593,49 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) } } -static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache) +static int not_in_rename(Scheme_Object *constrain_to_syms, Scheme_Object *rename) +{ + int istart, iend, ri; + Scheme_Object *renamed, *s; + + while (SCHEME_PAIRP(constrain_to_syms)) { + + s = SCHEME_CAR(constrain_to_syms); + extract_lex_range(rename, s, &istart, &iend); + + for (ri = istart; ri < iend; ri++) { + renamed = SCHEME_VEC_ELS(rename)[2+ri]; + if (SAME_OBJ(renamed, s)) + return 0; + } + + constrain_to_syms = SCHEME_CDR(constrain_to_syms); + } + + return 1; +} + +static int not_in_rib(Scheme_Object *constrain_to_syms, Scheme_Lexical_Rib *rib) +{ + for (rib = rib->next; rib; rib = rib->next) { + if (!not_in_rename(constrain_to_syms, rib->rename)) + return 0; + } + return 1; +} + +#define EXPLAIN_R(x) /* empty */ + +static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache, + Scheme_Object *stx_datum) { WRAP_POS w, prev, w2; - Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs = NULL, *prev_prec_ribs; - Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false; + Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs, *prev_prec_ribs; + Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false, *constrain_to_syms = NULL; Scheme_Object *v, *v2, *v2l, *v2rdl, *stx, *name, *svl, *end_mutable = NULL, **v2_rib_delims = NULL, *svrdl; Scheme_Lexical_Rib *did_rib = NULL; Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; - int copy_on_write, no_rib_mutation = 1; + int copy_on_write, no_rib_mutation = 1, rib_count = 0; long size, vsize, psize, i, j, pos; /* Although it makes no sense to simplify the rename table itself, @@ -5563,25 +5669,81 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab the symbol and marks. So, we have to compute that summary as we go in. */ + if (SCHEME_SYMBOLP(stx_datum)) { + /* Search for prunings */ + WRAP_POS_INIT(w, wraps); + old_key = NULL; + prec_ribs = NULL; + while (!WRAP_POS_END_P(w)) { + if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) + || SCHEME_RIBP(WRAP_POS_FIRST(w))) { + /* Lexical rename --- maybe an already-simplified point */ + key = WRAP_POS_KEY(w); + if (!SAME_OBJ(key, old_key)) { + v = scheme_hash_get(lex_cache, key); + if (v && SCHEME_HASHTP(v)) { + v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false); + } else if (prec_ribs) + v = NULL; + } else + v = NULL; + old_key = key; + + if (v) { + /* Tables here are already simplified. */ + break; + } + + if (SCHEME_RIBP(WRAP_POS_FIRST(w))) { + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(w); + if (!nonempty_rib(rib)) + prec_ribs = add_skip_set(rib->timestamp, prec_ribs); + } + } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(w))) { + v = SCHEME_BOX_VAL(WRAP_POS_FIRST(w)); + if (is_member(stx_datum, v)) { + if (!constrain_to_syms) + constrain_to_syms = v; + else { + v2 = scheme_null; + while (SCHEME_PAIRP(v)) { + if (is_member(SCHEME_CAR(v), constrain_to_syms)) + v2 = scheme_make_pair(SCHEME_CAR(v), v2); + v = SCHEME_CDR(v); + } + constrain_to_syms = v2; + } + } else + constrain_to_syms = scheme_null; + } + WRAP_POS_INC(w); + } + } + WRAP_POS_INIT(w, wraps); WRAP_POS_INIT_END(prev); old_key = NULL; + prec_ribs = NULL; v2l = scheme_null; v2rdl = NULL; EXPLAIN_S(fprintf(stderr, "[in simplify]\n")); + EXPLAIN_R(printf("Simplifying %p\n", lex_cache)); + while (!WRAP_POS_END_P(w)) { if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) || SCHEME_RIBP(WRAP_POS_FIRST(w))) { /* Lexical rename */ key = WRAP_POS_KEY(w); + EXPLAIN_R(printf(" key %p\n", key)); if (!SAME_OBJ(key, old_key)) { - if (!prec_ribs) - v = scheme_hash_get(lex_cache, key); - else + v = scheme_hash_get(lex_cache, key); + if (v && SCHEME_HASHTP(v)) { + v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false); + } else if (prec_ribs) v = NULL; } else v = NULL; @@ -5609,11 +5771,15 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab return NULL; } if (SAME_OBJ(did_rib, rib) - || !nonempty_rib(rib)) { + || !nonempty_rib(rib) + || (constrain_to_syms && !not_in_rib(constrain_to_syms, rib))) { skip_this = 1; + if (!nonempty_rib(rib)) + prec_ribs = add_skip_set(rib->timestamp, prec_ribs); EXPLAIN_S(fprintf(stderr, " to skip %p=%s\n", rib, scheme_write_to_string(rib->timestamp, NULL))); } else { + rib_count++; did_rib = rib; prec_ribs = add_skip_set(rib->timestamp, prec_ribs); @@ -5623,6 +5789,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab copy_on_write = 1; + EXPLAIN_R(printf(" rib %p\n", rib->timestamp)); + /* Compute, per id, whether to skip later instances of rib: */ for (rib = rib->next; rib; rib = rib->next) { vsize = SCHEME_RENAME_LEN(rib->rename); @@ -5636,8 +5804,9 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_write_to_string(SCHEME_VEC_ELS(rib->rename)[0], NULL))); /* already skipped? */ - if (!skip_ribs_ht - || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp))) { + if ((!constrain_to_syms || is_member(SCHEME_STX_VAL(stx), constrain_to_syms)) + && (!skip_ribs_ht + || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp)))) { /* No. Should we skip? */ Scheme_Object *other_env; other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i]; @@ -5649,6 +5818,11 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; } + { + Scheme_Object *e; + e = extend_cached_env(SCHEME_VEC_ELS(rib->rename)[2+vsize+i], other_env, prec_ribs, 0); + SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = e; + } } WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); if (same_marks(&w2, &w, other_env)) { @@ -5678,7 +5852,15 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab if ((SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */ && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2])) { add = 1; - } + + if (constrain_to_syms) { + /* Maybe pruned so that we don't need to resolve: */ + if (not_in_rename(constrain_to_syms, v)) + skip_this = 1; + } + } + EXPLAIN_R(printf(" lex reset\n")); + did_rib = NULL; } if (add) { @@ -5709,11 +5891,31 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab rib_delim = WRAP_POS_FIRST(w); if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) rib_delim = scheme_false; + if (rib_count > 1) { + EXPLAIN_R(if (did_rib) printf(" reset delim %d\n", rib_count)); + did_rib = NULL; + } + rib_count = 0; + } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(w))) { + v = WRAP_POS_FIRST(w); + WRAP_POS_COPY(w2, w); + WRAP_POS_INC(w2); + if (!WRAP_POS_END_P(w2) && SAME_OBJ(v, WRAP_POS_FIRST(w2))) { + WRAP_POS_INC(w); + } else { + EXPLAIN_R(printf(" reset by mark\n")); + did_rib = NULL; + } + } else { + EXPLAIN_R(if (did_rib) printf(" reset %d\n", SCHEME_TYPE(WRAP_POS_FIRST(w)))); + did_rib = NULL; } - + WRAP_POS_INC(w); } + EXPLAIN_R(printf(" ... phase2\n")); + while (!SCHEME_NULLP(stack)) { key = SCHEME_CAR(stack); prev_prec_ribs = SCHEME_VEC_ELS(key)[1]; @@ -5803,9 +6005,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab name = SCHEME_STX_VAL(stx); SCHEME_VEC_ELS(v2)[2+pos] = name; - if (!rib - || !skip_ribs_ht - || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(name, rib->timestamp))) { + if ((!constrain_to_syms || is_member(name, constrain_to_syms)) + && (!rib + || !skip_ribs_ht + || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(name, rib->timestamp)))) { /* Either this name is in prev, in which case the answer must match this rename's target, or this rename's answer applies. */ @@ -5840,6 +6043,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab ok = other_env; SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; ok = NULL; + } else { + ok = extend_cached_env(SCHEME_VEC_ELS(v)[2+vvsize+ii], other_env, prec_ribs, 0); + SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; + ok = NULL; } } @@ -6044,19 +6251,36 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab WRAP_POS_DEC(w); } - if (!prev_prec_ribs) { - /* no dependency on ribs, so we can globally cache this result */ - scheme_hash_set(lex_cache, key, v2l); + if (!constrain_to_syms) { + v = scheme_hash_get(lex_cache, key); + if (!v && !prev_prec_ribs) { + /* no dependency on ribs, so we can simply cache this result: */ + scheme_hash_set(lex_cache, key, v2l); + } else { + Scheme_Hash_Table *ht; + if (v && SCHEME_HASHTP(v)) + ht = (Scheme_Hash_Table *)v; + else { + ht = scheme_make_hash_table(SCHEME_hash_ptr); + } + if (v && !SCHEME_HASHTP(v)) + scheme_hash_set(ht, scheme_false, v); + scheme_hash_set(ht, prev_prec_ribs ? prev_prec_ribs : scheme_false, v2l); + scheme_hash_set(lex_cache, key, (Scheme_Object *)ht); + } end_mutable = v2l; } stack = SCHEME_CDR(stack); } + EXPLAIN_R(printf(" ... done\n")); + return v2l; } -static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, +static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, + Scheme_Object *w_in, Scheme_Marshal_Tables *mt, Scheme_Hash_Table *rns, int just_simplify) @@ -6064,7 +6288,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *prec_ribs = scheme_null; WRAP_POS w; Scheme_Hash_Table *lex_cache, *reverse_map; - int stack_size = 0; + int stack_size = 0, specific_to_datum = 0; if (!rns) rns = mt->rns; @@ -6098,8 +6322,11 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, scheme_hash_set(rns, scheme_void, (Scheme_Object *)lex_cache); } + if (!just_simplify) + stx_datum = scheme_false; + /* Ensures that all lexical tables in w have been simplified */ - simplifies = simplify_lex_renames(w_in, lex_cache); + simplifies = simplify_lex_renames(w_in, lex_cache, stx_datum); if (mt) scheme_marshal_push_refs(mt); @@ -6382,6 +6609,16 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, stack_size++; } else if (SCHEME_HASHTP(a)) { /* chain-specific cache; drop it */ + } else if (SCHEME_PRUNEP(a)) { + if (SCHEME_SYMBOLP(stx_datum)) { + /* Assuming that there are lex renames later, then this chain is + specific to this wrap. */ + specific_to_datum = 1; + } + if (!just_simplify) + a = scheme_box(SCHEME_BOX_VAL(a)); + stack = CONS(a, stack); + stack_size++; } else { /* box, a phase shift */ /* We used to drop a phase shift if there are no following @@ -6459,8 +6696,9 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, return a; } } - - scheme_hash_set(reverse_map, stack, w_in); + + if (!specific_to_datum) + scheme_hash_set(reverse_map, stack, w_in); } /* Convert to a chunk if just simplifying. @@ -6487,7 +6725,8 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, /* Remember this wrap set: */ if (just_simplify) { - scheme_hash_set(rns, w_in, stack); + if (!specific_to_datum) + scheme_hash_set(rns, w_in, stack); return stack; } else { return scheme_marshal_wrap_set(mt, w_in, stack); @@ -6670,7 +6909,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, if (with_marks) { v = extract_for_common_wrap(v, 1, 0); if (v && SAME_OBJ(common_wraps, v)) { - converted_wraps = wraps_to_datum(stx->wraps, mt, NULL, 0); + converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0); if (SAME_OBJ(common_wraps, converted_wraps)) lift_common_wraps(first, common_wraps, cnt, 1); else @@ -6688,7 +6927,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, first = scheme_make_pair(scheme_make_integer(cnt), first); } } else if (with_marks && SCHEME_TRUEP(common_wraps)) { - converted_wraps = wraps_to_datum(stx->wraps, mt, NULL, 0); + converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0); if (SAME_OBJ(common_wraps, converted_wraps)) lift_common_wraps(first, common_wraps, cnt, 0); else @@ -6750,7 +6989,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, if (with_marks > 1) { if (!converted_wraps) - converted_wraps = wraps_to_datum(stx->wraps, mt, NULL, 0); + converted_wraps = wraps_to_datum(stx->val, stx->wraps, mt, NULL, 0); result = CONS(result, converted_wraps); if (stx->certs) { Scheme_Object *cert_marks = scheme_null, *icert_marks = scheme_null; @@ -7348,9 +7587,19 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, 1); } else if (SCHEME_SYMBOLP(a)) { /* mark barrier */ + } else if (SCHEME_BOXP(a)) { + if (SCHEME_PAIRP(SCHEME_BOX_VAL(a))) { + /* prune context */ + a = make_prune_context(SCHEME_BOX_VAL(a)); + } else { + /* must be a phase shift */ + Scheme_Object *vec; + vec = SCHEME_BOX_VAL(a); + if (!SCHEME_VECTORP(vec)) return_NULL; + if (SCHEME_VEC_SIZE(vec) != 4) return_NULL; + } } else { - /* must be a box for a phase shift */ - /* (or garbage due to a bad .zo, and we'll ignore it) */ + return_NULL; } if (wc) @@ -7827,7 +8076,7 @@ static void simplify_syntax_inner(Scheme_Object *o, scheme_stx_content((Scheme_Object *)stx); if (rns) { - v = wraps_to_datum(stx->wraps, NULL, rns, 1); + v = wraps_to_datum(stx->val, stx->wraps, NULL, rns, 1); stx->wraps = v; } @@ -8638,6 +8887,32 @@ static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv) return do_module_binding("identifier-label-binding", argc, argv, scheme_false); } +static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv) +{ + Scheme_Object *a = argv[0], *p, *l; + + if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) + scheme_wrong_type("identifier-prune-lexical-context", "identifier syntax", 0, argc, argv); + + if (argc > 1) { + l = argv[1]; + while (SCHEME_PAIRP(l)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(l))) + break; + l = SCHEME_CDR(l); + } + if (!SCHEME_NULLP(l)) + scheme_wrong_type("identifier-prune-lexical-context", "list of symbols", 1, argc, argv); + l = argv[1]; + } else { + l = scheme_make_pair(SCHEME_STX_VAL(a), scheme_null); + } + + p = make_prune_context(l); + + return scheme_add_rename(a, p); +} + static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv) { if (!SCHEME_STXP(argv[0])) diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index 2fad5a151d..1220ff31f2 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -170,84 +170,85 @@ enum { scheme_free_id_info_type, /* 152 */ scheme_rib_delimiter_type, /* 153 */ scheme_noninline_proc_type, /* 154 */ + scheme_prune_context_type, /* 155 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 155 */ + _scheme_last_normal_type_, /* 156 */ - scheme_rt_weak_array, /* 156 */ + scheme_rt_weak_array, /* 157 */ - scheme_rt_comp_env, /* 157 */ - scheme_rt_constant_binding, /* 158 */ - scheme_rt_resolve_info, /* 159 */ - scheme_rt_optimize_info, /* 160 */ - scheme_rt_compile_info, /* 161 */ - scheme_rt_cont_mark, /* 162 */ - scheme_rt_saved_stack, /* 163 */ - scheme_rt_reply_item, /* 164 */ - scheme_rt_closure_info, /* 165 */ - scheme_rt_overflow, /* 166 */ - scheme_rt_overflow_jmp, /* 167 */ - scheme_rt_meta_cont, /* 168 */ - scheme_rt_dyn_wind_cell, /* 169 */ - scheme_rt_dyn_wind_info, /* 170 */ - scheme_rt_dyn_wind, /* 171 */ - scheme_rt_dup_check, /* 172 */ - scheme_rt_thread_memory, /* 173 */ - scheme_rt_input_file, /* 174 */ - scheme_rt_input_fd, /* 175 */ - scheme_rt_oskit_console_input, /* 176 */ - scheme_rt_tested_input_file, /* 177 */ - scheme_rt_tested_output_file, /* 178 */ - scheme_rt_indexed_string, /* 179 */ - scheme_rt_output_file, /* 180 */ - scheme_rt_load_handler_data, /* 181 */ - scheme_rt_pipe, /* 182 */ - scheme_rt_beos_process, /* 183 */ - scheme_rt_system_child, /* 184 */ - scheme_rt_tcp, /* 185 */ - scheme_rt_write_data, /* 186 */ - scheme_rt_tcp_select_info, /* 187 */ - scheme_rt_namespace_option, /* 188 */ - scheme_rt_param_data, /* 189 */ - scheme_rt_will, /* 190 */ - scheme_rt_struct_proc_info, /* 191 */ - scheme_rt_linker_name, /* 192 */ - scheme_rt_param_map, /* 193 */ - scheme_rt_finalization, /* 194 */ - scheme_rt_finalizations, /* 195 */ - scheme_rt_cpp_object, /* 196 */ - scheme_rt_cpp_array_object, /* 197 */ - scheme_rt_stack_object, /* 198 */ - scheme_rt_preallocated_object, /* 199 */ - scheme_thread_hop_type, /* 200 */ - scheme_rt_srcloc, /* 201 */ - scheme_rt_evt, /* 202 */ - scheme_rt_syncing, /* 203 */ - scheme_rt_comp_prefix, /* 204 */ - scheme_rt_user_input, /* 205 */ - scheme_rt_user_output, /* 206 */ - scheme_rt_compact_port, /* 207 */ - scheme_rt_read_special_dw, /* 208 */ - scheme_rt_regwork, /* 209 */ - scheme_rt_buf_holder, /* 210 */ - scheme_rt_parameterization, /* 211 */ - scheme_rt_print_params, /* 212 */ - scheme_rt_read_params, /* 213 */ - scheme_rt_native_code, /* 214 */ - scheme_rt_native_code_plus_case, /* 215 */ - scheme_rt_jitter_data, /* 216 */ - scheme_rt_module_exports, /* 217 */ - scheme_rt_delay_load_info, /* 218 */ - scheme_rt_marshal_info, /* 219 */ - scheme_rt_unmarshal_info, /* 220 */ - scheme_rt_runstack, /* 221 */ - scheme_rt_sfs_info, /* 222 */ - scheme_rt_validate_clearing, /* 223 */ - scheme_rt_rb_node, /* 224 */ + scheme_rt_comp_env, /* 158 */ + scheme_rt_constant_binding, /* 159 */ + scheme_rt_resolve_info, /* 160 */ + scheme_rt_optimize_info, /* 161 */ + scheme_rt_compile_info, /* 162 */ + scheme_rt_cont_mark, /* 163 */ + scheme_rt_saved_stack, /* 164 */ + scheme_rt_reply_item, /* 165 */ + scheme_rt_closure_info, /* 166 */ + scheme_rt_overflow, /* 167 */ + scheme_rt_overflow_jmp, /* 168 */ + scheme_rt_meta_cont, /* 169 */ + scheme_rt_dyn_wind_cell, /* 170 */ + scheme_rt_dyn_wind_info, /* 171 */ + scheme_rt_dyn_wind, /* 172 */ + scheme_rt_dup_check, /* 173 */ + scheme_rt_thread_memory, /* 174 */ + scheme_rt_input_file, /* 175 */ + scheme_rt_input_fd, /* 176 */ + scheme_rt_oskit_console_input, /* 177 */ + scheme_rt_tested_input_file, /* 178 */ + scheme_rt_tested_output_file, /* 179 */ + scheme_rt_indexed_string, /* 180 */ + scheme_rt_output_file, /* 181 */ + scheme_rt_load_handler_data, /* 182 */ + scheme_rt_pipe, /* 183 */ + scheme_rt_beos_process, /* 184 */ + scheme_rt_system_child, /* 185 */ + scheme_rt_tcp, /* 186 */ + scheme_rt_write_data, /* 187 */ + scheme_rt_tcp_select_info, /* 188 */ + scheme_rt_namespace_option, /* 189 */ + scheme_rt_param_data, /* 190 */ + scheme_rt_will, /* 191 */ + scheme_rt_struct_proc_info, /* 192 */ + scheme_rt_linker_name, /* 193 */ + scheme_rt_param_map, /* 194 */ + scheme_rt_finalization, /* 195 */ + scheme_rt_finalizations, /* 196 */ + scheme_rt_cpp_object, /* 197 */ + scheme_rt_cpp_array_object, /* 198 */ + scheme_rt_stack_object, /* 199 */ + scheme_rt_preallocated_object, /* 200 */ + scheme_thread_hop_type, /* 201 */ + scheme_rt_srcloc, /* 202 */ + scheme_rt_evt, /* 203 */ + scheme_rt_syncing, /* 204 */ + scheme_rt_comp_prefix, /* 205 */ + scheme_rt_user_input, /* 206 */ + scheme_rt_user_output, /* 207 */ + scheme_rt_compact_port, /* 208 */ + scheme_rt_read_special_dw, /* 209 */ + scheme_rt_regwork, /* 210 */ + scheme_rt_buf_holder, /* 211 */ + scheme_rt_parameterization, /* 212 */ + scheme_rt_print_params, /* 213 */ + scheme_rt_read_params, /* 214 */ + scheme_rt_native_code, /* 215 */ + scheme_rt_native_code_plus_case, /* 216 */ + scheme_rt_jitter_data, /* 217 */ + scheme_rt_module_exports, /* 218 */ + scheme_rt_delay_load_info, /* 219 */ + scheme_rt_marshal_info, /* 220 */ + scheme_rt_unmarshal_info, /* 221 */ + scheme_rt_runstack, /* 222 */ + scheme_rt_sfs_info, /* 223 */ + scheme_rt_validate_clearing, /* 224 */ + scheme_rt_rb_node, /* 225 */ #endif - scheme_place_type, /* 225 */ - scheme_engine_type, /* 226 */ + scheme_place_type, /* 226 */ + scheme_engine_type, /* 227 */ _scheme_last_type_ }; diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index bffa739a18..0f868b9bb3 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -622,6 +622,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_rib_delimiter_type, small_object); GC_REG_TRAV(scheme_noninline_proc_type, small_object); + GC_REG_TRAV(scheme_prune_context_type, small_object); } END_XFORM_SKIP; From aba257c81646bf2d5775565739a5a4ae13fcd885 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 17 May 2009 13:47:28 +0000 Subject: [PATCH 37/39] fix shadowing of language-supplied bindings when loading from bytecode (merge to 4.2) svn: r14851 --- src/mzscheme/src/stxobj.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index c719a54981..1d85c7227e 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -1893,7 +1893,8 @@ static void unmarshal_rename(Module_Renames *mrn, if (sealed) mrn->sealed = 0; - for (l = mrn->unmarshal_info; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + l = scheme_reverse(mrn->unmarshal_info); + for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { scheme_do_module_rename_unmarshal((Scheme_Object *)mrn, SCHEME_CAR(l), modidx_shift_from, modidx_shift_to, export_registry); From a6b38844eea1ad6bd8c94110b4290b0ca0690421 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 18 May 2009 00:48:55 +0000 Subject: [PATCH 38/39] added an error check to colorize and removed dependency on mzlib/etc svn: r14852 --- collects/texpict/private/common-unit.ss | 107 ++++++++++++------------ 1 file changed, 55 insertions(+), 52 deletions(-) diff --git a/collects/texpict/private/common-unit.ss b/collects/texpict/private/common-unit.ss index f0ef465281..e17d620eee 100644 --- a/collects/texpict/private/common-unit.ss +++ b/collects/texpict/private/common-unit.ss @@ -1,8 +1,9 @@ #lang scheme/unit - (require mzlib/etc) - + (require scheme/gui/base + scheme/class) + (require "common-sig.ss") (import texpict-common-setup^) @@ -445,48 +446,49 @@ (let ([make-append-boxes (lambda (wcomb hcomb fxoffset fyoffset rxoffset ryoffset combine-ascent combine-descent) - (rec *-append - (lambda (sep . args) - (unless (number? sep) - (set! args (cons sep args)) - (set! sep 0)) - (let append-boxes ([args args]) - (cond - [(null? args) (blank)] - [(null? (cdr args)) (car args)] - [else - (let* ([first (car args)] - [rest (append-boxes (cdr args))] - [w (wcomb (pict-width first) (pict-width rest) sep first rest)] - [h (hcomb (pict-height first) (pict-height rest) sep first rest)] - [fw (pict-width first)] - [fh (pict-height first)] - [rw (pict-width rest)] - [rh (pict-height rest)] - [fd1 (pict-ascent first)] - [fd2 (pict-descent first)] - [rd1 (pict-ascent rest)] - [rd2 (pict-descent rest)] - [dx1 (fxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] - [dy1 (fyoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)] - [dx2 (rxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] - [dy2 (ryoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)]) - (make-pict - `(picture - ,w ,h - (put ,dx1 - ,dy1 - ,(pict-draw first)) - (put ,dx2 - ,dy2 - ,(pict-draw rest))) - w h - (combine-ascent fd1 rd1 fd2 rd2 fh rh h (+ dy1 fh) (+ dy2 rh)) - (combine-descent fd2 rd2 fd1 rd1 fh rh h (- h dy1) (- h dy2)) - (list (make-child first dx1 dy1 1 1) - (make-child rest dx2 dy2 1 1)) - #f - (or (pict-last rest) rest)))])))))] + (letrec ([*-append + (lambda (sep . args) + (unless (number? sep) + (set! args (cons sep args)) + (set! sep 0)) + (let append-boxes ([args args]) + (cond + [(null? args) (blank)] + [(null? (cdr args)) (car args)] + [else + (let* ([first (car args)] + [rest (append-boxes (cdr args))] + [w (wcomb (pict-width first) (pict-width rest) sep first rest)] + [h (hcomb (pict-height first) (pict-height rest) sep first rest)] + [fw (pict-width first)] + [fh (pict-height first)] + [rw (pict-width rest)] + [rh (pict-height rest)] + [fd1 (pict-ascent first)] + [fd2 (pict-descent first)] + [rd1 (pict-ascent rest)] + [rd2 (pict-descent rest)] + [dx1 (fxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] + [dy1 (fyoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)] + [dx2 (rxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] + [dy2 (ryoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)]) + (make-pict + `(picture + ,w ,h + (put ,dx1 + ,dy1 + ,(pict-draw first)) + (put ,dx2 + ,dy2 + ,(pict-draw rest))) + w h + (combine-ascent fd1 rd1 fd2 rd2 fh rh h (+ dy1 fh) (+ dy2 rh)) + (combine-descent fd2 rd2 fd1 rd1 fh rh h (- h dy1) (- h dy2)) + (list (make-child first dx1 dy1 1 1) + (make-child rest dx2 dy2 1 1)) + #f + (or (pict-last rest) rest)))])))]) + *-append))] [2max (lambda (a b c . rest) (max a b))] [zero (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 . args) 0)] [fv (lambda (a b . args) a)] @@ -895,14 +897,15 @@ (lambda (x) (and x #t)))) - (define colorize - (case-lambda - [(p color) - (if (black-and-white) - p - (extend-pict - p 0 0 0 0 0 - `(color ,color ,(pict-draw p))))])) + (define (colorize p color) + (unless (or (string? color) + (is-a? color color%)) + (error 'colorize "expected a color, given ~e" color)) + (if (black-and-white) + p + (extend-pict + p 0 0 0 0 0 + `(color ,color ,(pict-draw p))))) (define (optimize s) (let o-loop ([s s][dx 0][dy 0]) From 7ef0e8258e2ca0783222ff6ed9f38207e40df675 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 18 May 2009 07:50:40 +0000 Subject: [PATCH 39/39] Welcome to a new PLT day. svn: r14853 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index d93619c4f3..23d23146ab 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "17may2009") +#lang scheme/base (provide stamp) (define stamp "18may2009") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index d2830a183a..bfa515ccf2 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@