From 9927b0b576063d2ee99a2089825098aa9a7e7781 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Feb 2009 22:04:51 +0000 Subject: [PATCH 001/142] changed htdp languages to allow identifier module paths; scribble improvements to latex back-end; added definterface svn: r13681 --- collects/lang/private/teach.ss | 10 ++++ collects/scheme/include.ss | 4 +- collects/scribble/latex-render.ss | 47 ++++++++++--------- collects/scribble/manual.ss | 1 + collects/scribble/private/manual-bind.ss | 32 +++++++++++++ collects/scribble/private/manual-class.ss | 19 ++++++-- collects/scribble/scribble.tex | 5 +- .../scribblings/htdp-langs/advanced.scrbl | 2 +- .../htdp-langs/beginner-abbr.scrbl | 2 +- .../scribblings/htdp-langs/beginner.scrbl | 7 +++ .../htdp-langs/intermediate-lambda.scrbl | 2 +- .../scribblings/htdp-langs/intermediate.scrbl | 2 +- collects/scribblings/reference/class.scrbl | 8 ++-- collects/scribblings/reference/sandbox.scrbl | 3 +- collects/scribblings/scribble/basic.scrbl | 4 +- collects/scribblings/scribble/manual.scrbl | 23 +++++++++ .../2htdp/scribblings/universe.scrbl | 4 +- 17 files changed, 133 insertions(+), 42 deletions(-) diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss index 7e305d8989..5330e7b815 100644 --- a/collects/lang/private/teach.ss +++ b/collects/lang/private/teach.ss @@ -1183,6 +1183,16 @@ (begin (check-string-form stx #'s) #'(require s))] + [(_ id) + (identifier? #'id) + (begin + (unless (module-path? (syntax-e #'id)) + (teach-syntax-error + 'require + stx + #'id + "bad syntax for a module path")) + #'(require id))] [(_ (lib . rest)) (let ([s (syntax->list #'rest)]) (unless ((length s) . >= . 2) diff --git a/collects/scheme/include.ss b/collects/scheme/include.ss index 45657159a7..94cace375b 100644 --- a/collects/scheme/include.ss +++ b/collects/scheme/include.ss @@ -32,7 +32,9 @@ [(pair? e) (or (loop (car e)) (loop (cdr e)))] [else #f]))) - read-syntax)]) + (lambda (src in) + (parameterize ([read-accept-reader #t]) + (read-syntax src in))))]) (unless (and (procedure? read-syntax) (procedure-arity-includes? read-syntax 2)) (raise-syntax-error diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 0c6724b273..e125e8fd24 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -228,14 +228,6 @@ (define/override (render-table t part ri inline-table?) (let* ([boxed? (eq? 'boxed (table-style t))] [index? (eq? 'index (table-style t))] - [inline? - (and (not boxed?) (not index?) - (or (null? (table-flowss t)) - (= 1 (length (car (table-flowss t))))) - (let ([m (current-table-mode)]) - (and m - (equal? "bigtabular" (car m)) - (= 1 (length (car (table-flowss (cadr m))))))))] [tableform (cond [index? "list"] [(and (not (current-table-mode)) (not inline-table?)) @@ -244,7 +236,21 @@ [opt (cond [(equal? tableform "bigtabular") "[l]"] [(equal? tableform "tabular") "[t]"] [else ""])] - [flowss (if index? (cddr (table-flowss t)) (table-flowss t))]) + [flowss (if index? (cddr (table-flowss t)) (table-flowss t))] + [row-styles (cdr (or (and (list? (table-style t)) + (assoc 'row-styles (table-style t))) + (cons #f (map (lambda (x) #f) flowss))))] + [inline? + (and (not boxed?) + (not index?) + (ormap (lambda (rs) (equal? rs "inferencetop")) row-styles) + (or (null? (table-flowss t)) + (= 1 (length (car (table-flowss t))))) + (let ([m (current-table-mode)]) + (and m + (equal? "bigtabular" (car m)) + (= 1 (length (car (table-flowss (cadr m))))))))] + [boxline "{\\setlength{\\unitlength}{\\linewidth}\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}"]) (unless (or (null? flowss) (null? (car flowss))) (parameterize ([current-table-mode (if inline? (current-table-mode) (list tableform t))] @@ -254,14 +260,7 @@ [index? (printf "\\begin{list}{}{\\parsep=0pt \\itemsep=1pt \\leftmargin=2ex \\itemindent=-2ex}\n")] [inline? (void)] [else - (printf "\n\n~a\\begin{~a}~a{@{}~a}\n" - (if boxed? - (format "{~a\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}~a\n\\nopagebreak\n" - "\\setlength{\\unitlength}{\\linewidth}" - (if (equal? tableform "bigtabular") - "\\bigtabline" - "\n\n")) - "") + (printf "\n\n\\begin{~a}~a{@{}~a}\n~a" tableform opt (string-append* @@ -276,12 +275,16 @@ (assoc 'alignment (or (table-style t) null))) (cons #f (map (lambda (x) #f) - (car flowss))))))))]) + (car flowss))))))) + (if boxed? + (if (equal? tableform "bigtabular") + (format "~a \\endfirsthead\n" boxline) + (format "\\multicolumn{~a}{@{}l@{}}{~a} \\\\\n" + (length (car flowss)) + boxline)) + ""))]) (let loop ([flowss flowss] - [row-styles - (cdr (or (and (list? (table-style t)) - (assoc 'row-styles (table-style t))) - (cons #f (map (lambda (x) #f) flowss))))]) + [row-styles row-styles]) (let ([flows (car flowss)] [row-style (car row-styles)]) (let loop ([flows flows]) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 1680771048..c902936141 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -14,6 +14,7 @@ (provide unsyntax make-binding-redirect-elements + defidentifier (all-from-out "basic.ss" "private/manual-style.ss" "private/manual-scheme.ss" diff --git a/collects/scribble/private/manual-bind.ss b/collects/scribble/private/manual-bind.ss index 331aa024b8..b136277545 100644 --- a/collects/scribble/private/manual-bind.ss +++ b/collects/scribble/private/manual-bind.ss @@ -26,6 +26,7 @@ with-exporting-libraries id-to-target-maker id-to-form-target-maker + defidentifier *sig-elem (struct-out sig) ;; public: @@ -170,6 +171,37 @@ (lambda () (car content)) (lambda () (car content)))))) +(define (defidentifier id + #:form? [form? #f] + #:index? [index? #t] + #:show-libs? [show-libs? #t]) + ;; This function could have more optional argument to select + ;; whether to index the id, include a toc link, etc. + (let ([dep? #t]) + (let ([maker (if form? + (id-to-form-target-maker id dep?) + (id-to-target-maker id dep?))] + [elem (if show-libs? + (definition-site (syntax-e id) id form?) + (to-element id))]) + (if maker + (maker (list elem) + (lambda (tag) + (let ([elem + (if index? + (make-index-element + #f (list elem) tag + (list (symbol->string (syntax-e id))) + (list elem) + (and show-libs? + (with-exporting-libraries + (lambda (libs) + (make-exported-index-desc (syntax-e id) + libs))))) + elem)]) + (make-target-element #f (list elem) tag)))) + elem)))) + (define (make-binding-redirect-elements mod-path redirects) (let ([taglet (module-path-index->taglet (module-path-index-join mod-path #f))]) diff --git a/collects/scribble/private/manual-class.ss b/collects/scribble/private/manual-class.ss index c76dbb224f..9d3a4968b7 100644 --- a/collects/scribble/private/manual-class.ss +++ b/collects/scribble/private/manual-class.ss @@ -173,11 +173,20 @@ (make-decl-collect decl) (append ((decl-mk-head decl) #f) - (list - (make-blockquote - "leftindent" - (flow-paragraphs - (decode-flow (build-body decl (decl-body decl)))))))))) + (let-values ([(pre post) + (let loop ([l (decl-body decl)][accum null]) + (cond + [(null? l) (values (reverse accum) null)] + [(or (constructor? (car l)) (meth? (car l))) + (values (reverse accum) l)] + [else (loop (cdr l) (cons (car l) accum))]))]) + (append + (flow-paragraphs (decode-flow pre)) + (list + (make-blockquote + "leftindent" + (flow-paragraphs + (decode-flow (build-body decl post))))))))))) (define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc) (make-table diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index 54d304a7a8..abd2ae20fd 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -15,6 +15,7 @@ \usepackage{hyperref} \renewcommand{\rmdefault}{ptm} \usepackage{longtable} +\usepackage{relsize} \usepackage[htt]{hyphenat} \usepackage[usenames,dvipsnames]{color} \hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true} @@ -67,8 +68,8 @@ \newcommand{\indexlink}[1]{#1} \newcommand{\noborder}[1]{#1} \newcommand{\imageleft}[1]{} % drop it -\newcommand{\smaller}[1]{{\footnotesize #1}} -\newcommand{\refpara}[1]{\marginpar{\footnotesize #1}} +\renewcommand{\smaller}[1]{\textsmaller{#1}} +\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}} \newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle} \newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle} diff --git a/collects/scribblings/htdp-langs/advanced.scrbl b/collects/scribblings/htdp-langs/advanced.scrbl index 9bc2d3983b..97fef1bd5d 100644 --- a/collects/scribblings/htdp-langs/advanced.scrbl +++ b/collects/scribblings/htdp-langs/advanced.scrbl @@ -349,6 +349,6 @@ The same as Beginning's @|beg-check-expect|, etc.} Constants for the empty list, true, and false.} -@defform[(require string)]{ +@defform[(require module-path)]{ The same as Beginning's @|beg-require|.} diff --git a/collects/scribblings/htdp-langs/beginner-abbr.scrbl b/collects/scribblings/htdp-langs/beginner-abbr.scrbl index bba47aa84f..37962fa30d 100644 --- a/collects/scribblings/htdp-langs/beginner-abbr.scrbl +++ b/collects/scribblings/htdp-langs/beginner-abbr.scrbl @@ -184,6 +184,6 @@ The same as Beginning's @|beg-check-expect|, etc.} Constants for the empty list, true, and false.} -@defform[(require string)]{ +@defform[(require module-path)]{ The same as Beginning's @|beg-require|.} diff --git a/collects/scribblings/htdp-langs/beginner.scrbl b/collects/scribblings/htdp-langs/beginner.scrbl index 1147bde639..170d3febd6 100644 --- a/collects/scribblings/htdp-langs/beginner.scrbl +++ b/collects/scribblings/htdp-langs/beginner.scrbl @@ -318,6 +318,13 @@ lowercase), @litchar{0} through @litchar{9}, @litchar{-}, @litchar{_}, and @litchar{.}, and the string cannot be empty or contain a leading or trailing @litchar{/}.} +@defform/none[#:literals (require) + (require module-id)]{ + +Accesses a file in an installed library. The library name is an +identifier with the same constraints as for a relative-path string, +with the additional constraint that it must not contain a +@litchar{.}.} @defform/none[#:literals (require lib) (require (lib string string ...))]{ diff --git a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl index 0ba2862bb4..f3c63795ce 100644 --- a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl +++ b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl @@ -187,6 +187,6 @@ The same as Beginning's @|beg-check-expect|, etc.} Constants for the empty list, true, and false.} -@defform[(require string)]{ +@defform[(require module-path)]{ The same as Beginning's @|beg-require|.} diff --git a/collects/scribblings/htdp-langs/intermediate.scrbl b/collects/scribblings/htdp-langs/intermediate.scrbl index 37fbd3c0e7..3f2b96991f 100644 --- a/collects/scribblings/htdp-langs/intermediate.scrbl +++ b/collects/scribblings/htdp-langs/intermediate.scrbl @@ -231,6 +231,6 @@ The same as Beginning's @|beg-check-expect|, etc.} Constants for the empty list, true, and false.} -@defform[(require string)]{ +@defform[(require module-path)]{ The same as Beginning's @|beg-require|.} diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 8f50eacd4b..a64ce5728f 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1494,7 +1494,7 @@ To customize the way that a class instance is compared to other instances by @scheme[equal?], implement the @scheme[equal<%>] interface. -@definterface[equal<%> ()]{} +@definterface[equal<%> ()]{ The @scheme[equal<%>] interface includes three methods, which are analogous to the functions provided for a structure type with @@ -1531,7 +1531,7 @@ classes whose most specific ancestor to explicitly implement See @scheme[prop:equal+hash] for more information on equality comparisons and hash codes. The @scheme[equal<%>] interface is -implemented with @scheme[interface*] and @scheme[prop:equal+hash]. +implemented with @scheme[interface*] and @scheme[prop:equal+hash].} @; ------------------------------------------------------------------------ @@ -1610,11 +1610,11 @@ Like @scheme[define-serializable-class*], but with not interface expressions (analogous to @scheme[class]).} -@definterface[externalizable<%> ()]{} +@definterface[externalizable<%> ()]{ The @scheme[externalizable<%>] interface includes only the @scheme[externalize] and @scheme[internalize] methods. See -@scheme[define-serializable-class*] for more information. +@scheme[define-serializable-class*] for more information.} @; ------------------------------------------------------------------------ diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 34eb823c43..386a62df8d 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -478,7 +478,8 @@ specifications in @scheme[sandbox-path-permissions], and it uses @defparam[sandbox-path-permissions perms - (listof (list/c (or/c 'execute 'write 'delete 'read-bytecode 'read 'exists) + (listof (list/c (or/c 'execute 'write 'delete + 'read-bytecode 'read 'exists) (or/c byte-regexp? bytes? string? path?)))]{ A parameter that configures the behavior of the default sandbox diff --git a/collects/scribblings/scribble/basic.scrbl b/collects/scribblings/scribble/basic.scrbl index 2492ae3436..6a68027557 100644 --- a/collects/scribblings/scribble/basic.scrbl +++ b/collects/scribblings/scribble/basic.scrbl @@ -163,7 +163,9 @@ an element with style @scheme[#f].} @def-style-proc[subscript] @def-style-proc[superscript] -@def-elem-proc[smaller]{Like @scheme[elem], but with style @scheme["smaller"].} +@def-elem-proc[smaller]{Like @scheme[elem], but with style +@scheme["smaller"]. When uses of @scheme[smaller] are nested, text +gets progressively smaller.} @defproc[(hspace [n exact-nonnegative-integer?]) element?]{ diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 9434c4999c..8fb1b956bb 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -613,6 +613,29 @@ typeset as with @scheme[scheme].} Like @scheme[schemegrammar], but for typesetting multiple productions at once, aligned around the @litchar{=} and @litchar{|}.} +@defproc[(defidentifier [id identifier?] + [#:form? form? any/c #f] + [#:index? index? any/c #t] + [#:show-libs? show-libs? any/c #t]) + element?]{ + +Typesets @scheme[id] as a Scheme identifier, and also establishes the +identifier as the definition of a binding in the same way as +@scheme[defproc], @scheme[defform], etc. As always, the library that +provides the identifier must be declared via @scheme[defmodule] or +@scheme[declare-exporting] for an enclosing section. + +If @scheme[form?] is a true value, then the identifier is documented +as a syntactic form, so that uses of the identifier (normally +including @scheme[id] itself) are typeset as a syntactic form. + +If @scheme[index?] is a true value, then the identifier is registered +in the index. + +If @scheme[show-libs?] is a true value, then the identifier's defining +module may be exposed in the typeset form (e.g., when viewing HTML and +the mouse hovers over the identifier).} + @; ------------------------------------------------------------------------ @section[#:tag "doc-classes"]{Documenting Classes and Interfaces} diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index a64bcff87f..b875e0a297 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -25,6 +25,8 @@ @author{Matthias Felleisen} +@defmodule[2htdp/universe #:use-sources (teachpack/htdp/image)] + @;{FIXME: the following paragraph uses `defterm' instead of `deftech', because the words "world" and "universe" are used as datatypes, and datatypes are currently linked as technical terms --- which is a hack. @@ -52,8 +54,6 @@ The purpose of this documentation is to give experienced Schemers and HtDP have a series of projects available as a small booklet on @link["http://world.cs.brown.edu/"]{How to Design Worlds}. -@declare-exporting[teachpack/2htdp/universe #:use-sources (teachpack/htdp/image)] - @; ----------------------------------------------------------------------------- @section[#:tag "basics"]{Basics} From c7809e5838816fee70e74622390d05c07b809062 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 16 Feb 2009 23:06:23 +0000 Subject: [PATCH 002/142] Use stxclass for require/opaque-type svn: r13682 --- collects/typed-scheme/private/prims.ss | 46 +++++++++----------------- 1 file changed, 15 insertions(+), 31 deletions(-) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 3c7a17209f..d34ce7dd0d 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -84,37 +84,21 @@ This file defines two sorts of primitives. All of them are provided into any mod 'typechecker:ignore #t)))))])) (define-syntax (require/opaque-type stx) - (syntax-case stx () - [(_ ty pred lib #:name-exists) - (begin - (unless (identifier? #'ty) - (raise-syntax-error #f "opaque type name must be an identifier" stx #'ty)) - (unless (identifier? #'pred) - (raise-syntax-error #f "opaque type predicate must be an identifier" stx #'pred)) - (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) - (quasisyntax/loc stx - (begin - #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) - 'typechecker:ignore #t) - #,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred)))) - #,(internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) - #,(syntax-property #'(require/contract pred pred-cnt lib) - 'typechecker:ignore #t))))] - [(_ ty pred lib) - (begin - (unless (identifier? #'ty) - (raise-syntax-error #f "opaque type name must be an identifier" stx #'ty)) - (unless (identifier? #'pred) - (raise-syntax-error #f "opaque type predicate must be an identifier" stx #'pred)) - (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) - (quasisyntax/loc stx - (begin - #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) - 'typechecker:ignore #t) - #,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred)))) - (define-type-alias ty (Opaque pred)) - #,(syntax-property #'(require/contract pred pred-cnt lib) - 'typechecker:ignore #t))))])) + (define-syntax-class name-exists-kw + (pattern #:name-exists)) + (syntax-parse stx + [(_ ty:id pred:id lib ([ne:name-exists-kw] #:opt) ...*) + (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) + (quasisyntax/loc stx + (begin + #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) + 'typechecker:ignore #t) + #,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred)))) + #,(if #'ne + (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) + (syntax/loc stx (define-type-alias ty (Opaque pred)))) + #,(syntax-property #'(require/contract pred pred-cnt lib) + 'typechecker:ignore #t)))])) (define-for-syntax (formal-annotation-error stx src) (let loop ([stx stx]) From ee32e728bc2de84922e729b1d8164353ae4ecf08 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Feb 2009 00:14:11 +0000 Subject: [PATCH 003/142] fix make-parameter for SRFI-39 svn: r13684 --- collects/srfi/39.ss | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/collects/srfi/39.ss b/collects/srfi/39.ss index 98c180b56b..818336bb56 100644 --- a/collects/srfi/39.ss +++ b/collects/srfi/39.ss @@ -1,3 +1,18 @@ -;; Supported by core PLT: +;; Supported by core PLT, with a slight difference in how a guard is used: #lang scheme/base -(provide make-parameter parameterize) + +(define make-parameter* + (let ([make-parameter + (case-lambda + [(v) (make-parameter v)] + [(v guard) (make-parameter (if (and (procedure? guard) + (procedure-arity-includes? guard 1)) + ;; apply guard to initial value: + (guard v) + ;; let `make-parameter' complain: + v) + guard)])]) + make-parameter)) + +(provide (rename-out [make-parameter* make-parameter]) + parameterize) From 723dc269030a666b78edd4681c18ef5b7d8578a0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Feb 2009 01:09:06 +0000 Subject: [PATCH 004/142] I think I'm finally getting the hang of this stuff ... svn: r13686 --- .../games/chat-noir/chat-noir-literate.ss | 885 ++++++++++-------- 1 file changed, 473 insertions(+), 412 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 661bb91bdb..bf1bcb7b79 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -113,10 +113,13 @@ A @scheme[cell] is a structure with two fields: (define-struct cell (p blocked?) #:transparent)] The first field contains a @scheme[posn] struct. The coordinates of -the posn indicate a position on the hexagonal grid. The @tt{y} field +the posn indicate a position on the hexagonal grid. +This program reprsents the hexagon grid as a series of rows that +are offset from each other by 1/2 the size of the each cell. +The @tt{y} field of the @scheme[posn] refers to the row of the cell, and the @tt{x} coordinate the position in the row. This means that, for example, -@scheme[(make-posn 0 1)] is centered above @scheme[(make-posn 1 0)] +@scheme[(make-posn 1 0)] is centered above @scheme[(make-posn 1 0)] and @scheme[(make-posn 1 1)]. (See @scheme[cell-center-x] and @scheme[cell-center-y] below for the conversion of those positions to screen coordinates.) @@ -126,63 +129,29 @@ clicked on, thus blocking the cat from stepping there. The @scheme[empty-board] function builds a list of @scheme[cell]s that correspond to an empty board. For example, here's what an empty -3x3 board looks like, as a list of cells. +7x7 board looks like, as a list of cells. -@chunk[ - - (test (empty-world 3) - (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false))] - -and here is what that board look like, when rendered. - -@image["3x3-empty-board.png"] -@image["5x5-empty-board.png"] @image["7x7-empty-board.png"] -@chunk[ - ;; empty-board : number -> (listof cell) - (define (empty-board board-size) - (filter - (lambda (c) - (not (and (= 0 (posn-x (cell-p c))) - (or (= 0 (posn-y (cell-p c))) - (= (- board-size 1) - (posn-y (cell-p c))))))) - (append-all - (build-list - board-size - (lambda (i) - (build-list - board-size - (lambda (j) - (make-cell (make-posn i j) - false))))))))] +It contains 7 rows and, with the exception of the first and last rows, +each row contains 7 cells. Notice how the even and odd rows are offset +from each other by 1/2 of the size of the cell. +The first and last row are missing their left-most cells +because those cells are useless, from the perspective of the gameplay, +Specifically, all of the neighbors of the missing cells +are also on the boundary and thus +the cat would win if it ever steps on one of those neighboring cells, +ending the game. -@chunk[ - - ;; empty-world : number -> world - (define (empty-world board-size) - (make-world (empty-board board-size) - (make-posn (quotient board-size 2) - (quotient board-size 2)) - 'playing - board-size - (make-posn 0 0) - false))] +The 3x3 board also has the same property that it consists of three +rows, each with three cells, but where the first and last row are missing +their left-most cells. -@chunk[ +@image["3x3-empty-board.png"] + +And here is how that board looks as a list of cells. + +@chunk[ (test (empty-board 3) (list @@ -194,6 +163,73 @@ and here is what that board look like, when rendered. (make-cell (make-posn 2 1) false) (make-cell (make-posn 2 2) false)))] +The @scheme[empty-board] function consists +of two (nested) calls to @scheme[build-list] +that build a list of lists of cells, one for +each pair of coordinates between @scheme[0] +and @scheme[board-size]. Then, @scheme[append] +flattens the nested lists and the +@scheme[filter] expression removes the corners. + +@chunk[ + ;; empty-board : number -> (listof cell) + (define (empty-board board-size) + (filter + (not-corner? board-size) + (apply + append + (build-list + board-size + (lambda (i) + (build-list + board-size + (lambda (j) + (make-cell (make-posn i j) + false)))))))) + + (define ((not-corner? board-size) c) + (not (and (= 0 (posn-x (cell-p c))) + (or (= 0 (posn-y (cell-p c))) + (= (- board-size 1) + (posn-y (cell-p c)))))))] + +Building an empty world is simply +a matter of building an empty board, finding +the initial position of the cat and filling +in all of the fields of the @scheme[world] struct. +For example, this is the empty world of size @scheme[3]. +It puts the cat at @scheme[(make-posn 1 1)], +sets the state to @scheme['playing], records the +size @scheme[3], and sets the current mouse position +to @scheme[false] and the state of the ``h'' key to +@scheme[false]. + +@chunk[ + + (test (empty-world 3) + (make-world (empty-board 3) + (make-posn 1 1) + 'playing + 3 + false + false))] + + +The @scheme[empty-world] function +generalizes the exmaple by computing the +cats initial position as the center spot on the board. + +@chunk[ + + (define (empty-world board-size) + (make-world (empty-board board-size) + (make-posn (quotient board-size 2) + (quotient board-size 2)) + 'playing + board-size + false + false))] + @section{Graph} @@ -212,9 +248,10 @@ X parts .... @chunk[ + + - @@ -241,10 +278,31 @@ which is a list of @scheme[dist-cell] structs: Each @tt{p} field in the @scheme[dist-cell] is a position on the board and the @tt{n} field is a natural number or @scheme['∞], indicating the distance of the shortest path from the node to some fixed point on -the board. The fixed point is not represented in the -@scheme[distance-map], but is required when constructing one. +the board. -The @scheme[build-bfs-table] accepts a world and +The @scheme[build-bfs-table] accepts a world and a cell +(indicating the fixed point) +and returns a distance map encoding the distance to that cell. +For example, here is the distance map for the distance to the boundary. + +@chunk[ + (test/set (build-bfs-table (empty-world 3) + 'boundary) + (list + (make-dist-cell 'boundary 0) + + (make-dist-cell (make-posn 1 0) 1) + (make-dist-cell (make-posn 2 0) 1) + + (make-dist-cell (make-posn 0 1) 1) + (make-dist-cell (make-posn 1 1) 2) + (make-dist-cell (make-posn 2 1) 1) + + (make-dist-cell (make-posn 1 2) 1) + (make-dist-cell (make-posn 2 2) 1)))] + +The boundary is zero steps away; each of the cells that are on the boundary +are one step away and the center is two steps away. The core of the breadth-first search is this function, @scheme[bst]. It accepts a queue of the pending nodes to visit @@ -291,29 +349,6 @@ The @scheme[build-bfs-table] function packages up @scheme[bfs] function. It accepts a @tt{world} and an initial position and returns a @scheme[distance-table]. -As an example, here is one of the test cases. It supplies -an empty world of size @scheme[3] to @scheme[build-bfs-table] -and @scheme['boundary], thus asking for the distance from -the boundary to each cell. - -@chunk[ - (test/set (build-bfs-table (empty-world 3) - 'boundary) - (list - (make-dist-cell 'boundary 0) - - (make-dist-cell (make-posn 1 0) 1) - (make-dist-cell (make-posn 2 0) 1) - - (make-dist-cell (make-posn 0 1) 1) - (make-dist-cell (make-posn 1 1) 2) - (make-dist-cell (make-posn 2 1) 1) - - (make-dist-cell (make-posn 1 2) 1) - (make-dist-cell (make-posn 2 2) 1)))] - -The result is a list - @chunk[ (define (build-bfs-table world init-point) @@ -327,16 +362,365 @@ The result is a list As you can see, the first thing it does is bind the free variable in @scheme[bfs] to the result of calling the @scheme[neighbors] function (defined in the chunk -@chunkref[]) and then it has the @scheme[bfs] function. In the body - -and finally it calls the bfs function +@chunkref[]) and then it has the @chunkref[] chunk. In the body +it calls the @scheme[bfs] function and then transforms the result, using -@scheme[hash-map]. +@scheme[hash-map], into a list of @scheme[cell]s. + +As far as the @scheme[build-bfs-table] function goes, +all of the information specific to Chat Noir is +encoded in the neighbors function. +It accepts a world and returns a function +that computes the neighbors of the boundary +and of nodes. + +For example, @scheme[(make-posn 1 0)] has four +neighbors: + +@chunk[ + (test ((neighbors (empty-world 7)) (make-posn 1 0)) + (list 'boundary + (make-posn 2 0) + (make-posn 0 1) + (make-posn 1 1)))] + +and @scheme[(make-posn 0 1)] has four neighbors: + +@chunk[ + (test ((neighbors (empty-world 7)) (make-posn 0 1)) + (list 'boundary + (make-posn 1 0) + (make-posn 1 1) + (make-posn 0 2) + (make-posn 1 2)))] + +as you can see from the pictures of the empty boards above. + +This is the neighbors function. It first accepts a @scheme[world] +and then builds a list of the blocked cells in the world and a +list of the cells that are on the boundary (and not blocked). + +The result is a function that accepts a @scheme[posn] or @scheme['boundary]. +If @scheme[p] is blocked, the function returns the empty list. If it is +on the boundary, the function simply returns @scheme[boundary-cells]. +Finally, + +@chunk[ +;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) +(define (neighbors w) + (define blocked + (map cell-p + (filter (lambda (c) + (or (cell-blocked? c) + (equal? (cell-p c) (world-mouse-posn w)))) + (world-board w)))) + (define boundary-cells + (filter (lambda (p) + (and (not (member p blocked)) + (on-boundary? p (world-size w)))) + (map cell-p (world-board w)))) + (λ (p) + (cond + [(member p blocked) + '()] + [(equal? p 'boundary) + boundary-cells] + [else + (let* ([x (posn-x p)] + [adjacent-posns + (filter (λ (x) (not (member x blocked))) + (adjacent p (world-size w)))] + [in-bounds + (filter (λ (x) (in-bounds? x (world-size w))) + adjacent-posns)]) + (cond + [(equal? in-bounds adjacent-posns) + in-bounds] + [else + (cons 'boundary in-bounds)]))])))] + +@chunk[ + (test ((neighbors (empty-world 11)) (make-posn 1 1)) + (adjacent (make-posn 1 1) 11)) + (test ((neighbors (empty-world 11)) (make-posn 2 2)) + (adjacent (make-posn 2 2) 11)) + (test ((neighbors (empty-world 3)) 'boundary) + (list (make-posn 0 1) + (make-posn 1 0) + (make-posn 1 2) + (make-posn 2 0) + (make-posn 2 1) + (make-posn 2 2))) + (test ((neighbors (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + 'playing + 3 + (make-posn 0 0) + false)) + (make-posn 1 1)) + '()) + (test ((neighbors (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + 'playing + 3 + (make-posn 0 0) + false)) + (make-posn 1 0)) + (list 'boundary (make-posn 2 0) (make-posn 0 1))) + ] + +@chunk[ +;; lookup-in-table : distance-map posn -> number or '∞ +;; looks for the distance as recorded in the table t, +;; if not found returns a distance of '∞ +(define (lookup-in-table t p) + (cond + [(empty? t) '∞] + [else (cond + [(equal? p (dist-cell-p (first t))) + (dist-cell-n (first t))] + [else + (lookup-in-table (rest t) p)])]))] + +@chunk[ + +(test (lookup-in-table empty (make-posn 1 2)) '∞) +(test (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3)) + (make-posn 1 2)) + 3) +(test (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3)) + (make-posn 1 2)) + '∞)] + + +@chunk[ +;; on-cats-path? : world -> posn -> boolean +;; returns true when the posn is on the shortest path +;; from the cat to the edge of the board, in the given world +(define (on-cats-path? w) + (cond + [(world-h-down? w) + (let () + (define edge-distance-map (build-bfs-table w 'boundary)) + (define cat-distance-map (build-bfs-table w (world-cat w))) + (define cat-distance (lookup-in-table edge-distance-map + (world-cat w))) + (cond + [(equal? cat-distance '∞) + (lambda (p) false)] + [else + (lambda (p) + (equal? (+/f (lookup-in-table cat-distance-map p) + (lookup-in-table edge-distance-map p)) + cat-distance))]))] + [else + (lambda (p) false)]))] + +@chunk[ +(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) true)) + (make-posn 1 0)) + true) +(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) false)) + (make-posn 1 0)) + false) +(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) true)) + (make-posn 2 1)) + false) +(test ((on-cats-path? + (make-world (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn 0 0) + true)) + (make-posn 0 1)) + false)] + + + +@chunk[ +;; adjacent : posn number -> (listof posn) +;; returns a list of the posns that are adjacent to +;; `p' on an infinite hex grid +(define (adjacent p board-size) + (local [(define x (posn-x p)) + (define y (posn-y p))] + (cond + [(even? y) + (list (make-posn (- x 1) (- y 1)) + (make-posn x (- y 1)) + (make-posn (- x 1) y) + (make-posn (+ x 1) y) + (make-posn (- x 1) (+ y 1)) + (make-posn x (+ y 1)))] + [else + (list (make-posn x (- y 1)) + (make-posn (+ x 1) (- y 1)) + (make-posn (- x 1) y) + (make-posn (+ x 1) y) + (make-posn x (+ y 1)) + (make-posn (+ x 1) (+ y 1)))])))] + +@chunk[ +(test (adjacent (make-posn 1 1) 11) + (list (make-posn 1 0) + (make-posn 2 0) + (make-posn 0 1) + (make-posn 2 1) + (make-posn 1 2) + (make-posn 2 2))) +(test (adjacent (make-posn 2 2) 11) + (list (make-posn 1 1) + (make-posn 2 1) + (make-posn 1 2) + (make-posn 3 2) + (make-posn 1 3) + (make-posn 2 3)))] + +@chunk[ +;; on-boundary? : posn number -> boolean +(define (on-boundary? p board-size) + (or (= (posn-x p) 0) + (= (posn-y p) 0) + (= (posn-x p) (- board-size 1)) + (= (posn-y p) (- board-size 1))))] + +@chunk[ +(test (on-boundary? (make-posn 0 1) 13) true) +(test (on-boundary? (make-posn 1 0) 13) true) +(test (on-boundary? (make-posn 12 1) 13) true) +(test (on-boundary? (make-posn 1 12) 13) true) +(test (on-boundary? (make-posn 1 1) 13) false) +(test (on-boundary? (make-posn 10 10) 13) false)] + +@chunk[ + +;; in-bounds? : posn number -> boolean +(define (in-bounds? p board-size) + (and (<= 0 (posn-x p) (- board-size 1)) + (<= 0 (posn-y p) (- board-size 1)) + (not (equal? p (make-posn 0 0))) + (not (equal? p (make-posn 0 (- board-size 1))))))] + +@chunk[ +(test (in-bounds? (make-posn 0 0) 11) false) +(test (in-bounds? (make-posn 0 1) 11) true) +(test (in-bounds? (make-posn 1 0) 11) true) +(test (in-bounds? (make-posn 10 10) 11) true) +(test (in-bounds? (make-posn 0 -1) 11) false) +(test (in-bounds? (make-posn -1 0) 11) false) +(test (in-bounds? (make-posn 0 11) 11) false) +(test (in-bounds? (make-posn 11 0) 11) false) +(test (in-bounds? (make-posn 10 0) 11) true) +(test (in-bounds? (make-posn 0 10) 11) false)] + +@chunk[ +;; <=/f : (number or '∞) (number or '∞) -> boolean +(define (<=/f a b) + (cond + [(equal? b '∞) true] + [(equal? a '∞) false] + [else (<= a b)])) + +(define (+/f x y) + (cond + [(or (equal? x '∞) (equal? y '∞)) + '∞] + [else + (+ x y)]))] + +@chunk[ +(test (<=/f 1 2) true) +(test (<=/f 2 1) false) +(test (<=/f '∞ 1) false) +(test (<=/f 1 '∞) true) +(test (<=/f '∞ '∞) true) + +(test (+/f '∞ '∞) '∞) +(test (+/f '∞ 1) '∞) +(test (+/f 1 '∞) '∞) +(test (+/f 1 2) 3)] + +@section{Tests} + +@chunk[ + +(define-syntax (test stx) + (syntax-case stx () + [(_ actual expected) + (with-syntax ([line (syntax-line stx)]) + #'(test/proc (λ () actual) + (λ () expected) + equal? + line))])) + +(define-syntax (test/set stx) + (syntax-case stx () + [(_ actual expected) + (with-syntax ([line (syntax-line stx)]) + #'(test/proc (λ () actual) + (λ () expected) + (λ (x y) (same-sets? x y)) + line))])) + +(define test-count 0) +(define test-procs '()) + +(define (test/proc actual-thunk expected-thunk cmp line) + (set! test-procs + (cons + (λ () + (set! test-count (+ test-count 1)) + (let ([actual (actual-thunk)] + [expected (expected-thunk)]) + (unless (cmp actual expected) + (error 'check-expect "test ~a on line ~a failed:\n ~s\n ~s\n" + test-count + line + actual + expected)))) + test-procs))) + + +(define (same-sets? l1 l2) + (and (andmap (lambda (e1) (member e1 l2)) l1) + (andmap (lambda (e2) (member e2 l1)) l2) + #t)) + +(test (same-sets? (list) (list)) true) +(test (same-sets? (list) (list 1)) false) +(test (same-sets? (list 1) (list)) false) +(test (same-sets? (list 1 2) (list 2 1)) true) + +(define (run-tests) + (for-each (λ (t) (t)) (reverse test-procs)) + (printf "passed ~s tests\n" test-count) + (flush-output))] -The test suite for the @scheme[build-bfs-table] function -uses @scheme[test/set] to avoid having to deal with the -ordering issues in @scheme[build-bfs-table]'s result. - @chunk[ (test/set (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) @@ -503,329 +887,6 @@ ordering issues in @scheme[build-bfs-table]'s result. (make-posn 1 4)) 2)] -@chunk[ -;; lookup-in-table : distance-map posn -> number or '∞ -;; looks for the distance as recorded in the table t, -;; if not found returns a distance of '∞ -(define (lookup-in-table t p) - (cond - [(empty? t) '∞] - [else (cond - [(equal? p (dist-cell-p (first t))) - (dist-cell-n (first t))] - [else - (lookup-in-table (rest t) p)])]))] - -@chunk[ - -(test (lookup-in-table empty (make-posn 1 2)) '∞) -(test (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3)) - (make-posn 1 2)) - 3) -(test (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3)) - (make-posn 1 2)) - '∞)] - - -@chunk[ -;; on-cats-path? : world -> posn -> boolean -;; returns true when the posn is on the shortest path -;; from the cat to the edge of the board, in the given world -(define (on-cats-path? w) - (cond - [(world-h-down? w) - (local [(define edge-distance-map (build-bfs-table w 'boundary)) - (define cat-distance-map (build-bfs-table w (world-cat w))) - (define cat-distance (lookup-in-table edge-distance-map - (world-cat w)))] - (cond - [(equal? cat-distance '∞) - (lambda (p) false)] - [else - (lambda (p) - (equal? (+/f (lookup-in-table cat-distance-map p) - (lookup-in-table edge-distance-map p)) - cat-distance))]))] - [else - (lambda (p) false)]))] - -@chunk[ -(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) true)) - (make-posn 1 0)) - true) -(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) false)) - (make-posn 1 0)) - false) -(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) true)) - (make-posn 2 1)) - false) -(test ((on-cats-path? - (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 0 0) - true)) - (make-posn 0 1)) - false)] - -@chunk[ -;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) -;; computes the neighbors of a posn, for a given board size -(define (neighbors w) - (local [(define blocked - (map cell-p - (filter (lambda (c) - (or (cell-blocked? c) - (equal? (cell-p c) (world-mouse-posn w)))) - (world-board w)))) - (define boundary-cells - (filter (lambda (p) - (and (not (member p blocked)) - (on-boundary? p (world-size w)))) - (map cell-p (world-board w))))] - (lambda (p) - (cond - [(member p blocked) - '()] - [(equal? p 'boundary) - boundary-cells] - [else - (local [(define x (posn-x p)) - (define y (posn-y p)) - (define adjacent-posns (adjacent p (world-size w))) - (define in-bounds - (filter (lambda (x) (in-bounds? x (world-size w))) - adjacent-posns))] - (filter - (lambda (x) (not (member x blocked))) - (cond - [(equal? in-bounds adjacent-posns) - in-bounds] - [else - (cons 'boundary in-bounds)])))]))))] - -@chunk[ -(test ((neighbors (empty-world 11)) (make-posn 1 1)) - (adjacent (make-posn 1 1) 11)) -(test ((neighbors (empty-world 11)) (make-posn 2 2)) - (adjacent (make-posn 2 2) 11)) -(test ((neighbors (empty-world 3)) 'boundary) - (list (make-posn 0 1) - (make-posn 1 0) - (make-posn 1 2) - (make-posn 2 0) - (make-posn 2 1) - (make-posn 2 2))) -(test ((neighbors (empty-world 11)) (make-posn 1 0)) - (list 'boundary - (make-posn 2 0) - (make-posn 0 1) - (make-posn 1 1))) -(test ((neighbors (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false)) - (make-posn 1 1)) - '()) -(test ((neighbors (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false)) - (make-posn 1 0)) - (list 'boundary (make-posn 2 0) (make-posn 0 1))) -] - -@chunk[ -;; adjacent : posn number -> (listof posn) -;; returns a list of the posns that are adjacent to -;; `p' on an infinite hex grid -(define (adjacent p board-size) - (local [(define x (posn-x p)) - (define y (posn-y p))] - (cond - [(even? y) - (list (make-posn (- x 1) (- y 1)) - (make-posn x (- y 1)) - (make-posn (- x 1) y) - (make-posn (+ x 1) y) - (make-posn (- x 1) (+ y 1)) - (make-posn x (+ y 1)))] - [else - (list (make-posn x (- y 1)) - (make-posn (+ x 1) (- y 1)) - (make-posn (- x 1) y) - (make-posn (+ x 1) y) - (make-posn x (+ y 1)) - (make-posn (+ x 1) (+ y 1)))])))] - -@chunk[ -(test (adjacent (make-posn 1 1) 11) - (list (make-posn 1 0) - (make-posn 2 0) - (make-posn 0 1) - (make-posn 2 1) - (make-posn 1 2) - (make-posn 2 2))) -(test (adjacent (make-posn 2 2) 11) - (list (make-posn 1 1) - (make-posn 2 1) - (make-posn 1 2) - (make-posn 3 2) - (make-posn 1 3) - (make-posn 2 3)))] - -@chunk[ -;; on-boundary? : posn number -> boolean -(define (on-boundary? p board-size) - (or (= (posn-x p) 0) - (= (posn-y p) 0) - (= (posn-x p) (- board-size 1)) - (= (posn-y p) (- board-size 1))))] - -@chunk[ -(test (on-boundary? (make-posn 0 1) 13) true) -(test (on-boundary? (make-posn 1 0) 13) true) -(test (on-boundary? (make-posn 12 1) 13) true) -(test (on-boundary? (make-posn 1 12) 13) true) -(test (on-boundary? (make-posn 1 1) 13) false) -(test (on-boundary? (make-posn 10 10) 13) false)] - -@chunk[ - -;; in-bounds? : posn number -> boolean -(define (in-bounds? p board-size) - (and (<= 0 (posn-x p) (- board-size 1)) - (<= 0 (posn-y p) (- board-size 1)) - (not (equal? p (make-posn 0 0))) - (not (equal? p (make-posn 0 (- board-size 1))))))] - -@chunk[ -(test (in-bounds? (make-posn 0 0) 11) false) -(test (in-bounds? (make-posn 0 1) 11) true) -(test (in-bounds? (make-posn 1 0) 11) true) -(test (in-bounds? (make-posn 10 10) 11) true) -(test (in-bounds? (make-posn 0 -1) 11) false) -(test (in-bounds? (make-posn -1 0) 11) false) -(test (in-bounds? (make-posn 0 11) 11) false) -(test (in-bounds? (make-posn 11 0) 11) false) -(test (in-bounds? (make-posn 10 0) 11) true) -(test (in-bounds? (make-posn 0 10) 11) false)] - -@chunk[ -;; <=/f : (number or '∞) (number or '∞) -> boolean -(define (<=/f a b) - (cond - [(equal? b '∞) true] - [(equal? a '∞) false] - [else (<= a b)])) - -(define (+/f x y) - (cond - [(or (equal? x '∞) (equal? y '∞)) - '∞] - [else - (+ x y)]))] - -@chunk[ -(test (<=/f 1 2) true) -(test (<=/f 2 1) false) -(test (<=/f '∞ 1) false) -(test (<=/f 1 '∞) true) -(test (<=/f '∞ '∞) true) - -(test (+/f '∞ '∞) '∞) -(test (+/f '∞ 1) '∞) -(test (+/f 1 '∞) '∞) -(test (+/f 1 2) 3)] - -@section{Init Junk} - -@chunk[ -] - -@chunk[ - -(define-syntax (test stx) - (syntax-case stx () - [(_ actual expected) - (with-syntax ([line (syntax-line stx)]) - #'(test/proc (λ () actual) - (λ () expected) - equal? - line))])) - -(define-syntax (test/set stx) - (syntax-case stx () - [(_ actual expected) - (with-syntax ([line (syntax-line stx)]) - #'(test/proc (λ () actual) - (λ () expected) - (λ (x y) (same-sets? x y)) - line))])) - -(define test-count 0) -(define test-procs '()) - -(define (test/proc actual-thunk expected-thunk cmp line) - (set! test-procs - (cons - (λ () - (set! test-count (+ test-count 1)) - (let ([actual (actual-thunk)] - [expected (expected-thunk)]) - (unless (cmp actual expected) - (error 'check-expect "test ~a on line ~a failed:\n ~s\n ~s\n" - test-count - line - actual - expected)))) - test-procs))) - - -(define (same-sets? l1 l2) - (and (andmap (lambda (e1) (member e1 l2)) l1) - (andmap (lambda (e2) (member e2 l1)) l2) - #t)) - -(test (same-sets? (list) (list)) true) -(test (same-sets? (list) (list 1)) false) -(test (same-sets? (list 1) (list)) false) -(test (same-sets? (list 1 2) (list 2 1)) true) - -(define (run-tests) - (for-each (λ (t) (t)) (reverse test-procs)) - (printf "passed ~s tests\n" test-count) - (flush-output))] - @section{Everything Else} From 0f18d68649bf7e0caa9e02f2739629129ef644e8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Feb 2009 01:15:38 +0000 Subject: [PATCH 005/142] Scribble: change handling of argumentd in defproc, etc., to use lexical bidning instead of parameters and symbols; fix some docs svn: r13688 --- collects/browser/browser.scrbl | 2 + collects/ffi/objc.scrbl | 3 +- collects/lazy/lazy.scrbl | 5 +- collects/scribble/private/manual-form.ss | 2 +- collects/scribble/private/manual-proc.ss | 11 +- collects/scribble/private/manual-vars.ss | 31 +++-- collects/scribble/scheme.ss | 124 ++++++++++-------- .../scribblings/reference/stx-patterns.scrbl | 6 +- collects/scribblings/scribble/manual.scrbl | 16 +-- collects/scribblings/scribble/reader.scrbl | 1 + 10 files changed, 120 insertions(+), 81 deletions(-) diff --git a/collects/browser/browser.scrbl b/collects/browser/browser.scrbl index a1a4bf0de6..5a9df3288a 100644 --- a/collects/browser/browser.scrbl +++ b/collects/browser/browser.scrbl @@ -7,6 +7,8 @@ browser/htmltext browser/external browser/tool + scheme/base + scheme/class scheme/gui/base net/url framework/framework)) diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl index 6a5d0c810a..a43ccb9713 100644 --- a/collects/ffi/objc.scrbl +++ b/collects/ffi/objc.scrbl @@ -2,7 +2,8 @@ @(require scribble/manual scribble/eval (for-label scheme/base - scheme/foreign + scheme/contract + (except-in scheme/foreign ->) "private/objc-doc-unsafe.ss")) @(define objc-eval (make-base-eval)) diff --git a/collects/lazy/lazy.scrbl b/collects/lazy/lazy.scrbl index 6dc56ae1ab..059a73296f 100644 --- a/collects/lazy/lazy.scrbl +++ b/collects/lazy/lazy.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc -@(require (for-label (except-in lazy delay force promise?) - (only-in lazy/force ! !! !list !!list))) +@(require (for-label (except-in lazy delay force) + (only-in lazy/force ! !! !list !!list) + scheme/contract)) @(define-syntax-rule (deflazy mod def id) (begin diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss index 8b348a6bf3..1302b65d5a 100644 --- a/collects/scribble/private/manual-form.ss +++ b/collects/scribble/private/manual-form.ss @@ -153,7 +153,7 @@ (syntax->list #'(lit ...))) #'(with-togetherable-scheme-variables (lit ...) - ([form spec]) + ([form/none spec]) (*defforms #f '(spec) (list (lambda (ignored) (schemeblock0/form spec))) null null diff --git a/collects/scribble/private/manual-proc.ss b/collects/scribble/private/manual-proc.ss index 110aa0fc30..22130a06c4 100644 --- a/collects/scribble/private/manual-proc.ss +++ b/collects/scribble/private/manual-proc.ss @@ -143,16 +143,17 @@ #f (list (schemeparenfont "[") (schemeidfont (keyword->string (arg-kw arg))) spacer - (to-element (arg-id arg)) + (to-element (make-var-id (arg-id arg))) (schemeparenfont "]"))) (make-element #f (list (to-element (arg-kw arg)) spacer - (to-element (arg-id arg))))) - (to-element (arg-id arg)))] + (to-element (make-var-id (arg-id arg)))))) + (to-element (make-var-id (arg-id arg))))] [(eq? (arg-id arg) '...+) dots1] [(eq? (arg-id arg) '...) dots0] - [else (to-element (arg-id arg))])] + [(eq? (arg-id arg) '_...superclass-args...) (to-element (arg-id arg))] + [else (to-element (make-var-id (arg-id arg)))])] [e (if (arg-ends-optional? arg) (make-element #f (list e "]")) e)] @@ -425,7 +426,7 @@ [def-len (if (arg-optional? arg) (block-width arg-val) 0)] [base-list (list (to-flow (hspace 2)) - (to-flow (to-element (arg-id arg))) + (to-flow (to-element (make-var-id (arg-id arg)))) flow-spacer (to-flow ":") flow-spacer diff --git a/collects/scribble/private/manual-vars.ss b/collects/scribble/private/manual-vars.ss index e5e566afc2..9d82498085 100644 --- a/collects/scribble/private/manual-vars.ss +++ b/collects/scribble/private/manual-vars.ss @@ -15,15 +15,23 @@ (define-struct (box-splice splice) ()) +(begin-for-syntax (define-struct deftogether-tag () #:omit-define-syntaxes)) + (define-syntax (with-togetherable-scheme-variables stx) (syntax-case stx () [(_ . rest) - ;; Make it transparent, so deftogether is allowed to pull it apart - (syntax-property - (syntax/loc stx - (with-togetherable-scheme-variables* . rest)) - 'certify-mode - 'transparent)])) + (let ([result (syntax/loc stx + (with-togetherable-scheme-variables* . rest))] + [ctx (syntax-local-context)]) + (if (and (pair? ctx) (deftogether-tag? (car ctx))) + ;; Make it transparent, so deftogether is allowed to pull it apart + (syntax-property result + 'certify-mode + 'transparent) + ;; Otherwise, don't make it transparent, because that + ;; removes certificates that will be needed on the `letrec-syntaxes' + ;; that we introduce later. + result))])) (define-syntax-rule (with-togetherable-scheme-variables* . rest) (with-scheme-variables . rest)) @@ -41,6 +49,7 @@ (if (identifier? arg) (unless (or (eq? (syntax-e arg) '...) (eq? (syntax-e arg) '...+) + (eq? (syntax-e arg) '_...superclass-args...) (memq (syntax-e arg) lits)) (bound-identifier-mapping-put! ht arg #t)) (syntax-case arg () @@ -51,11 +60,12 @@ (identifier? #'arg) (bound-identifier-mapping-put! ht #'arg #t)]))) (cdr (syntax->list s-exp)))] - [(form form/maybe non-term) + [(form form/none form/maybe non-term) (let loop ([form (case (syntax-e kind) [(form) (if (identifier? s-exp) null (cdr (syntax-e s-exp)))] + [(form/none) s-exp] [(form/maybe) (syntax-case s-exp () [(#f form) #'form] @@ -64,6 +74,9 @@ (if (identifier? form) (unless (or (eq? (syntax-e form) '...) (eq? (syntax-e form) '...+) + (eq? (syntax-e form) 'code:line) + (eq? (syntax-e form) 'code:blank) + (eq? (syntax-e form) 'code:comment) (eq? (syntax-e form) '?) (memq (syntax-e form) lits)) (bound-identifier-mapping-put! ht form #t)) @@ -81,7 +94,7 @@ (syntax->list #'(kind ...)) (syntax->list #'(s-exp ...))) (with-syntax ([(id ...) (bound-identifier-mapping-map ht (lambda (k v) k))]) - #'(parameterize ([current-variable-list '(id ...)]) + #'(letrec-syntaxes ([(id) (make-variable-id 'id)] ...) body)))])) @@ -112,7 +125,7 @@ (map (lambda (def) (let ([exp-def (local-expand def - 'expression + (list (make-deftogether-tag)) (cons #'with-togetherable-scheme-variables* (kernel-form-identifier-list)))]) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 443af073be..0a201e6005 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -20,9 +20,11 @@ current-variable-list current-meta-list + (struct-out var-id) (struct-out shaped-parens) (struct-out just-context) - (struct-out literal-syntax)) + (struct-out literal-syntax) + (for-syntax make-variable-id)) (define no-color "schemeplain") (define reader-color "schemereader") @@ -118,57 +120,63 @@ (make-element style content))) (define (typeset-atom c out color? quote-depth) - (let*-values ([(is-var?) (and (identifier? c) - (memq (syntax-e c) (current-variable-list)))] - [(s it? sub?) - (let ([sc (syntax-e c)]) - (let ([s (format "~s" (if (literal-syntax? sc) - (literal-syntax-stx sc) - sc))]) - (if (and (symbol? sc) - ((string-length s) . > . 1) - (char=? (string-ref s 0) #\_) - (not (or (identifier-label-binding c) - is-var?))) - (values (substring s 1) #t #f) - (values s #f #f))))]) - (if (or (element? (syntax-e c)) - (delayed-element? (syntax-e c)) - (part-relative-element? (syntax-e c))) - (out (syntax-e c) #f) - (out (if (and (identifier? c) - color? - (quote-depth . <= . 0) - (not (or it? is-var?))) - (if (pair? (identifier-label-binding c)) - (make-id-element c s) - s) - (literalize-spaces s)) - (cond - [(positive? quote-depth) value-color] - [(let ([v (syntax-e c)]) - (or (number? v) - (string? v) - (bytes? v) - (char? v) - (regexp? v) - (byte-regexp? v) - (boolean? v))) - value-color] - [(identifier? c) - (cond - [is-var? - variable-color] - [(and (identifier? c) - (memq (syntax-e c) (current-keyword-list))) - keyword-color] - [(and (identifier? c) - (memq (syntax-e c) (current-meta-list))) - meta-color] - [it? variable-color] - [else symbol-color])] - [else paren-color]) - (string-length s))))) + (if (var-id? (syntax-e c)) + (out (format "~s" (let ([v (var-id-sym (syntax-e c))]) + (if (syntax? v) + (syntax-e v) + v))) + variable-color) + (let*-values ([(is-var?) (and (identifier? c) + (memq (syntax-e c) (current-variable-list)))] + [(s it? sub?) + (let ([sc (syntax-e c)]) + (let ([s (format "~s" (if (literal-syntax? sc) + (literal-syntax-stx sc) + sc))]) + (if (and (symbol? sc) + ((string-length s) . > . 1) + (char=? (string-ref s 0) #\_) + (not (or (identifier-label-binding c) + is-var?))) + (values (substring s 1) #t #f) + (values s #f #f))))]) + (if (or (element? (syntax-e c)) + (delayed-element? (syntax-e c)) + (part-relative-element? (syntax-e c))) + (out (syntax-e c) #f) + (out (if (and (identifier? c) + color? + (quote-depth . <= . 0) + (not (or it? is-var?))) + (if (pair? (identifier-label-binding c)) + (make-id-element c s) + s) + (literalize-spaces s)) + (cond + [(positive? quote-depth) value-color] + [(let ([v (syntax-e c)]) + (or (number? v) + (string? v) + (bytes? v) + (char? v) + (regexp? v) + (byte-regexp? v) + (boolean? v))) + value-color] + [(identifier? c) + (cond + [is-var? + variable-color] + [(and (identifier? c) + (memq (syntax-e c) (current-keyword-list))) + keyword-color] + [(and (identifier? c) + (memq (syntax-e c) (current-meta-list))) + meta-color] + [it? variable-color] + [else symbol-color])] + [else paren-color]) + (string-length s)))))) (define (gen-typeset c multi-line? prefix1 prefix suffix color?) (let* ([c (syntax-ize c 0)] @@ -590,6 +598,8 @@ (define ((to-paragraph/prefix pfx1 pfx sfx) c) (typeset c #t pfx1 pfx sfx #t)) + (begin-for-syntax (define-struct variable-id (sym) #:omit-define-syntaxes)) + (define-syntax (define-code stx) (syntax-case stx () [(_ code typeset-code uncode d->s stx-prop) @@ -597,6 +607,15 @@ (define-syntax (code stx) (define (stx->loc-s-expr v) (cond + [(and (identifier? v) + (variable-id? (syntax-local-value v (lambda () #f)))) + `(,#'d->s #f + (,#'make-var-id ',(variable-id-sym (syntax-local-value v))) + #(code + ,(syntax-line v) + ,(syntax-column v) + ,(syntax-position v) + ,(syntax-span v)))] [(syntax? v) (let ([mk `(,#'d->s (quote-syntax ,(datum->syntax v 'defcode)) @@ -666,6 +685,7 @@ (loop (cons (car r) r) (sub1 i))))) l)))) + (define-struct var-id (sym)) (define-struct shaped-parens (val shape)) (define-struct just-context (val ctx)) (define-struct literal-syntax (stx)) diff --git a/collects/scribblings/reference/stx-patterns.scrbl b/collects/scribblings/reference/stx-patterns.scrbl index 13d853b7f3..e2791a22bf 100644 --- a/collects/scribblings/reference/stx-patterns.scrbl +++ b/collects/scribblings/reference/stx-patterns.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "mz.ss") -@(define ellipses (scheme ...)) +@(define lit-ellipses (scheme ...)) @title[#:tag "stx-patterns"]{Pattern-Based Syntax Matching} @@ -26,7 +26,7 @@ (stat-pattern ...+ . stat-pattern) (code:line #,(tt "#")(stat-pattern ...)) const] - [ellipses #,ellipses])]{ + [ellipses #,lit-ellipses])]{ Finds the first @scheme[pattern] that matches the syntax object produced by @scheme[stx-expr], and for which the corresponding @@ -205,7 +205,7 @@ the individual @scheme[stx-expr].} (code:line #,(tt "#")(stat-template ...)) (code:line #,(tt "#s")(key-datum stat-template ...)) const] - [ellipses #,ellipses])]{ + [ellipses #,lit-ellipses])]{ Constructs a syntax object based on a @scheme[template],which can inlude @tech{pattern variables} bound by @scheme[syntax-case] or diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 8fb1b956bb..6b97fcad28 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -4,8 +4,8 @@ (for-syntax scheme/base) (for-label scribble/manual-struct)) -@(define ellipses (scheme ...)) -@(define ellipses+ (scheme ...+)) +@(define lit-ellipses (scheme ...)) +@(define lit-ellipses+ (scheme ...+)) @title[#:tag "manual" #:style 'toc]{Manual Forms} @@ -357,8 +357,8 @@ sub-sections.} (keyword arg-id contract-expr-datum default-expr) ellipses ellipses+] - [ellipses #, @ellipses] - [ellipses+ #, @ellipses+])]{ + [ellipses #, @lit-ellipses] + [ellipses+ #, @lit-ellipses+])]{ Produces a sequence of flow elements (encapsulated in a @scheme[splice]) to document a procedure named @scheme[id]. Nesting @@ -393,14 +393,14 @@ Each @scheme[arg-spec] must have one of the following forms: Like the previous case, but with a default value.} -@specsubform[#, @ellipses]{Any number of the preceding argument. This +@specsubform[#, @lit-ellipses]{Any number of the preceding argument. This form is normally used at the end, but keyword-based arguments can sensibly appear afterward. See also the documentation for - @scheme[append] for a use of @ellipses before the last + @scheme[append] for a use of @lit-ellipses before the last argument.} -@specsubform[#, @ellipses+]{One or more of the preceding argument - (normally at the end, like @ellipses).} +@specsubform[#, @lit-ellipses+]{One or more of the preceding argument + (normally at the end, like @lit-ellipses).} The @scheme[result-contract-expr-datum] is typeset via @scheme[schemeblock0], and it represents a contract on the procedure's diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl index 0b4babd035..449b1d971b 100644 --- a/collects/scribblings/scribble/reader.scrbl +++ b/collects/scribblings/scribble/reader.scrbl @@ -926,4 +926,5 @@ line counting for the current input-port via @scheme[port-count-lines!].} @; *** End reader-import section *** ))])) @with-scribble-read[] + From c82cc16dfc9f2022430c4b99422ee7b0cf4ca6e8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Feb 2009 08:50:18 +0000 Subject: [PATCH 006/142] Welcome to a new PLT day. svn: r13689 --- 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 a63781735b..bb3f8b2aac 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "16feb2009") +#lang scheme/base (provide stamp) (define stamp "17feb2009") From 80bcae687ce4a5a4b1eb6541da2e1c7ab4b03cf3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Feb 2009 13:48:39 +0000 Subject: [PATCH 007/142] put the requires in the right place svn: r13690 --- .../games/chat-noir/chat-noir-literate.ss | 197 ++++++++++-------- 1 file changed, 114 insertions(+), 83 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index bf1bcb7b79..928133a95c 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,8 +1,5 @@ #reader "literate-reader.ss" -@(require scheme/local scheme/list scheme/bool scheme/math - (for-syntax scheme/base)) - @title{Chat Noir} The goal of Chat Noir is to stop the cat from escaping the board. Each @@ -37,7 +34,9 @@ code that handles drawing of the world, code that handles user input, and some code that builds an initial world and starts the game. @chunk[
- (require htdp/world lang/posn) + (require scheme/local scheme/list scheme/bool scheme/math + (for-syntax scheme/base)) + (require htdp/world lang/posn scheme/contract) @@ -172,8 +171,8 @@ flattens the nested lists and the @scheme[filter] expression removes the corners. @chunk[ - ;; empty-board : number -> (listof cell) - (define (empty-board board-size) + (define/contract (empty-board board-size) + (-> natural-number/c (listof cell?)) (filter (not-corner? board-size) (apply @@ -187,7 +186,8 @@ flattens the nested lists and the (make-cell (make-posn i j) false)))))))) - (define ((not-corner? board-size) c) + (define/contract ((not-corner? board-size) c) + (-> natural-number/c (-> cell? boolean?)) (not (and (= 0 (posn-x (cell-p c))) (or (= 0 (posn-y (cell-p c))) (= (- board-size 1) @@ -249,6 +249,7 @@ X parts .... + @@ -374,6 +375,10 @@ It accepts a world and returns a function that computes the neighbors of the boundary and of nodes. +The neighbors functions accepts a @scheme[world] and then +returns a function that computes the neighbors of a @scheme[posn] +and of the @scheme['boundary]. + For example, @scheme[(make-posn 1 0)] has four neighbors: @@ -394,16 +399,23 @@ and @scheme[(make-posn 0 1)] has four neighbors: (make-posn 0 2) (make-posn 1 2)))] -as you can see from the pictures of the empty boards above. +as you can see from the pictures of the 7x7 empty board above. +Also, there are 6 neighbors of the boundary in the 3x3 board: -This is the neighbors function. It first accepts a @scheme[world] -and then builds a list of the blocked cells in the world and a -list of the cells that are on the boundary (and not blocked). +@chunk[ + (test ((neighbors (empty-world 3)) 'boundary) + (list (make-posn 0 1) + (make-posn 1 0) + (make-posn 1 2) + (make-posn 2 0) + (make-posn 2 1) + (make-posn 2 2)))] -The result is a function that accepts a @scheme[posn] or @scheme['boundary]. -If @scheme[p] is blocked, the function returns the empty list. If it is -on the boundary, the function simply returns @scheme[boundary-cells]. -Finally, + +This is the neighbors function. After it accepts the @scheme[world], +it builds a list of the blocked cells in the world and a +list of the cells that are on the boundary (and not blocked). Then it +returns a function that is specialized to those values. @chunk[ ;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) @@ -420,68 +432,45 @@ Finally, (on-boundary? p (world-size w)))) (map cell-p (world-board w)))) (λ (p) - (cond - [(member p blocked) - '()] - [(equal? p 'boundary) - boundary-cells] - [else - (let* ([x (posn-x p)] - [adjacent-posns - (filter (λ (x) (not (member x blocked))) - (adjacent p (world-size w)))] - [in-bounds - (filter (λ (x) (in-bounds? x (world-size w))) - adjacent-posns)]) - (cond - [(equal? in-bounds adjacent-posns) - in-bounds] - [else - (cons 'boundary in-bounds)]))])))] + (neighbors-blocked/boundary blocked + boundary-cells + (world-size w) + p)))] + +The @scheme[neighbors-blocked/boundary] function is given next. +If @scheme[p] is blocked, it returns the empty list. If it is +on the boundary, the function simply returns @scheme[boundary-cells]. +Otherwise, @scheme[neighbors-blocked/boundary] calls +@scheme[adjacent] to compute the posns that are adjacent to @scheme[p], +filtering out the blocked @scheme[posn]s and binds that to @scheme[adjacent-posns]. +It then filters out the @scheme[posn]s that would be outside of the board. +If those two lists are the same, then @scheme[p] is not on the boundary, +so we just return @scheme[in-bounds]. If the lists are different, then +we know that @scheme[p] must have been on the boundary, so we add +@scheme['boundary] to the result list. + +@chunk[ +;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) +(define (neighbors-blocked/boundary blocked boundary-cells size p) + (cond + [(member p blocked) + '()] + [(equal? p 'boundary) + boundary-cells] + [else + (let* ([x (posn-x p)] + [adjacent-posns + (filter (λ (x) (not (member x blocked))) + (adjacent p))] + [in-bounds + (filter (λ (x) (in-bounds? x size)) + adjacent-posns)]) + (cond + [(equal? in-bounds adjacent-posns) + in-bounds] + [else + (cons 'boundary in-bounds)]))]))] -@chunk[ - (test ((neighbors (empty-world 11)) (make-posn 1 1)) - (adjacent (make-posn 1 1) 11)) - (test ((neighbors (empty-world 11)) (make-posn 2 2)) - (adjacent (make-posn 2 2) 11)) - (test ((neighbors (empty-world 3)) 'boundary) - (list (make-posn 0 1) - (make-posn 1 0) - (make-posn 1 2) - (make-posn 2 0) - (make-posn 2 1) - (make-posn 2 2))) - (test ((neighbors (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false)) - (make-posn 1 1)) - '()) - (test ((neighbors (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false)) - (make-posn 1 0)) - (list 'boundary (make-posn 2 0) (make-posn 0 1))) - ] @chunk[ ;; lookup-in-table : distance-map posn -> number or '∞ @@ -517,8 +506,8 @@ Finally, (let () (define edge-distance-map (build-bfs-table w 'boundary)) (define cat-distance-map (build-bfs-table w (world-cat w))) - (define cat-distance (lookup-in-table edge-distance-map - (world-cat w))) + (define cat-distance + (lookup-in-table edge-distance-map (world-cat w))) (cond [(equal? cat-distance '∞) (lambda (p) false)] @@ -563,10 +552,10 @@ Finally, @chunk[ -;; adjacent : posn number -> (listof posn) +;; adjacent : posn -> (listof posn) ;; returns a list of the posns that are adjacent to ;; `p' on an infinite hex grid -(define (adjacent p board-size) +(define (adjacent p) (local [(define x (posn-x p)) (define y (posn-y p))] (cond @@ -586,14 +575,14 @@ Finally, (make-posn (+ x 1) (+ y 1)))])))] @chunk[ -(test (adjacent (make-posn 1 1) 11) +(test (adjacent (make-posn 1 1)) (list (make-posn 1 0) (make-posn 2 0) (make-posn 0 1) (make-posn 2 1) (make-posn 1 2) (make-posn 2 2))) -(test (adjacent (make-posn 2 2) 11) +(test (adjacent (make-posn 2 2)) (list (make-posn 1 1) (make-posn 2 1) (make-posn 1 2) @@ -887,6 +876,48 @@ Finally, (make-posn 1 4)) 2)] +@chunk[ + (test ((neighbors (empty-world 11)) (make-posn 1 1)) + (adjacent (make-posn 1 1))) + (test ((neighbors (empty-world 11)) (make-posn 2 2)) + (adjacent (make-posn 2 2))) + (test ((neighbors (empty-world 3)) 'boundary) + (list (make-posn 0 1) + (make-posn 1 0) + (make-posn 1 2) + (make-posn 2 0) + (make-posn 2 1) + (make-posn 2 2))) + (test ((neighbors (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + 'playing + 3 + (make-posn 0 0) + false)) + (make-posn 1 1)) + '()) + (test ((neighbors (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + 'playing + 3 + (make-posn 0 0) + false)) + (make-posn 1 0)) + (list 'boundary (make-posn 2 0) (make-posn 0 1)))] @section{Everything Else} @@ -1537,7 +1568,7 @@ Finally, (define (move-cat world) (local [(define cat-position (world-cat world)) (define table (build-bfs-table world 'boundary)) - (define neighbors (adjacent cat-position (world-size world))) + (define neighbors (adjacent cat-position)) (define next-cat-positions (find-best-positions neighbors (map (lambda (p) (lookup-in-table table p)) From db5cab09e7fdcf6cc3b51ffb873ab359ec16a087 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Feb 2009 13:51:35 +0000 Subject: [PATCH 008/142] doc scribble/scheme; add make-element-id-transformer svn: r13691 --- collects/scribble/scheme.ss | 88 +++++++------ collects/scribblings/scribble/scheme.scrbl | 145 ++++++++++++++++++++- 2 files changed, 190 insertions(+), 43 deletions(-) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 0a201e6005..9767ff7ee0 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -24,7 +24,10 @@ (struct-out shaped-parens) (struct-out just-context) (struct-out literal-syntax) - (for-syntax make-variable-id)) + (for-syntax make-variable-id + variable-id? + make-element-id-transformer + element-id-transformer?)) (define no-color "schemeplain") (define reader-color "schemereader") @@ -598,53 +601,56 @@ (define ((to-paragraph/prefix pfx1 pfx sfx) c) (typeset c #t pfx1 pfx sfx #t)) - (begin-for-syntax (define-struct variable-id (sym) #:omit-define-syntaxes)) + (begin-for-syntax + (define-struct variable-id (sym) #:omit-define-syntaxes) + (define-struct element-id-transformer (proc) #:omit-define-syntaxes)) (define-syntax (define-code stx) (syntax-case stx () [(_ code typeset-code uncode d->s stx-prop) (syntax/loc stx (define-syntax (code stx) + (define (wrap-loc v ctx e) + `(,#'d->s ,ctx + ,e + #(code + ,(syntax-line v) + ,(syntax-column v) + ,(syntax-position v) + ,(syntax-span v)))) (define (stx->loc-s-expr v) - (cond - [(and (identifier? v) - (variable-id? (syntax-local-value v (lambda () #f)))) - `(,#'d->s #f - (,#'make-var-id ',(variable-id-sym (syntax-local-value v))) - #(code - ,(syntax-line v) - ,(syntax-column v) - ,(syntax-position v) - ,(syntax-span v)))] - [(syntax? v) - (let ([mk `(,#'d->s - (quote-syntax ,(datum->syntax v 'defcode)) - ,(syntax-case v (uncode) - [(uncode e) #'e] - [else (stx->loc-s-expr (syntax-e v))]) - #(code - ,(syntax-line v) - ,(syntax-column v) - ,(syntax-position v) - ,(syntax-span v)))]) - (let ([prop (syntax-property v 'paren-shape)]) - (if prop - `(,#'stx-prop ,mk 'paren-shape ,prop) - mk)))] - [(null? v) 'null] - [(list? v) `(list . ,(map stx->loc-s-expr v))] - [(pair? v) `(cons ,(stx->loc-s-expr (car v)) - ,(stx->loc-s-expr (cdr v)))] - [(vector? v) `(vector ,@(map - stx->loc-s-expr - (vector->list v)))] - [(and (struct? v) (prefab-struct-key v)) - `(make-prefab-struct (quote ,(prefab-struct-key v)) - ,@(map - stx->loc-s-expr - (cdr (vector->list (struct->vector v)))))] - [(box? v) `(box ,(stx->loc-s-expr (unbox v)))] - [else `(quote ,v)])) + (let ([slv (and (identifier? v) + (syntax-local-value v (lambda () #f)))]) + (cond + [(variable-id? slv) + (wrap-loc v #f `(,#'make-var-id ',(variable-id-sym slv)))] + [(element-id-transformer? slv) + (wrap-loc v #f ((element-id-transformer-proc slv) v))] + [(syntax? v) + (let ([mk (wrap-loc + v + `(quote-syntax ,(datum->syntax v 'defcode)) + (syntax-case v (uncode) + [(uncode e) #'e] + [else (stx->loc-s-expr (syntax-e v))]))]) + (let ([prop (syntax-property v 'paren-shape)]) + (if prop + `(,#'stx-prop ,mk 'paren-shape ,prop) + mk)))] + [(null? v) 'null] + [(list? v) `(list . ,(map stx->loc-s-expr v))] + [(pair? v) `(cons ,(stx->loc-s-expr (car v)) + ,(stx->loc-s-expr (cdr v)))] + [(vector? v) `(vector ,@(map + stx->loc-s-expr + (vector->list v)))] + [(and (struct? v) (prefab-struct-key v)) + `(make-prefab-struct (quote ,(prefab-struct-key v)) + ,@(map + stx->loc-s-expr + (cdr (vector->list (struct->vector v)))))] + [(box? v) `(box ,(stx->loc-s-expr (unbox v)))] + [else `(quote ,v)]))) (define (cvt s) (datum->syntax #'here (stx->loc-s-expr s) #f)) (syntax-case stx () diff --git a/collects/scribblings/scribble/scheme.scrbl b/collects/scribblings/scribble/scheme.scrbl index df9598412e..5c7376738b 100644 --- a/collects/scribblings/scribble/scheme.scrbl +++ b/collects/scribblings/scribble/scheme.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require scribble/manual - "utils.ss") + "utils.ss" + (for-label scribble/scheme)) @title[#:tag "scheme"]{Scheme} @@ -8,4 +9,144 @@ provides utilities for typesetting Scheme code. The @scheme[scribble/manual] forms provide a higher-level interface.} -@italic{To do:} document this library! +@defform*[[(define-code id typeset-expr) + (define-code id typeset-expr uncode-id) + (define-code id typeset-expr uncode-id d->s-expr) + (define-code id typeset-expr uncode-id d->s-expr stx-prop-expr)]]{ + +Binds @scheme[id] to a form similar to @scheme[scheme] or +@scheme[schemeblock] for typesetting code. The form generated by +@scheme[define-code] handles source-location information, escapes via +@scheme[unquote], preservation of binding and property information, +and @tech{element transformers}. + +The supplied @scheme[typeset-expr] expression should produce a +procedure that performs the actual typesetting. This expression is +normally @scheme[to-element] or @scheme[to-paragraph]. The argument +supplied to @scheme[typeset-expr] is normally a syntax object, but +more generally it is the result of applying @scheme[d->s-expr]. + +The optional @scheme[uncode-id] specifies the escape from literal code +to be recognized by @scheme[id]. The default is @scheme[unsyntax]. + +The optional @scheme[d->s-expr] should produce a procedure that +accepts three arguments suitable for @scheme[datum->syntax]: a syntax +object or @scheme[#f], an arbitrary value, and a vector for a source +location. The result should record as much or as little of the +argument information as needed by @scheme[typeset-expr] to typeset the +code. Normally, @scheme[d->s-expr] is @scheme[datum->syntax]. + +The @scheme[stx-prop-expr] should produce a procedure for recording a +@scheme['paren-shape] property when the source expression uses with +@scheme[id] has such a property. The default is +@scheme[syntax-property].} + +@defproc[(to-paragraph [v any/c]) block?]{ + +Typesets an S-expression that is represented by a syntax object, where +source-location information in the syntax object controls the +generated layout. + +Identifiers that have @scheme[for-label] bindings are typeset and +hyperlinked based on definitions declared elsewhere (via +@scheme[defproc], @scheme[defform], etc.). The identifiers +@schemeidfont{code:line}, @schemeidfont{code:comment}, and +@schemeidfont{code:blank} are handled as in @scheme[schemeblock], as +are identifiers that start with @litchar{_}. + +In addition, the given @scheme[v] can contain @scheme[var-id], +@scheme[shaped-parens], @scheme[just-context], or +@scheme[literal-syntax] structures to be typeset specially (see each +structure type for details), or it can contain @scheme[element] +structures that are used directly in the output.} + + +@defproc[((to-paragraph/prefix [prefix1 any/c] [prefix any/c] [suffix any/c]) + [v any/c]) + block?]{ + +Like @scheme[to-paragraph], but @scheme[prefix1] is prefixed onto the +first line, @scheme[prefix] is prefix to any subsequent line, and +@scheme[suffix] is added to the end. The @scheme[prefix1], +@scheme[prefix], and @scheme[suffix] arguments are used as +@tech{elements}, except that if @scheme[suffix] is a list of elements, +it is added to the end on its own line.} + + +@defproc[(to-element [v any/c]) element?]{ + +Like @scheme[to-paragraph], except that source-location information is +mostly ignored, since the result is meant to be inlined into a +paragraph.} + +@defproc[(to-element/no-color [v any/c]) element?]{ + +Like @scheme[to-element], but @scheme[for-syntax] bindings are +ignored, and the generated text is uncolored. This variant is +typically used to typeset results.} + + +@defstruct[var-id ([sym (or/c symbol? identifier?)])]{ + +When @scheme[to-paragraph] and variants encounter a @scheme[var-id] +structure, it is typeset as @scheme[sym] in the variable font, like +@scheme[schemevarfont].} + + +@defstruct[shaped-parens ([val any/c] + [shape char?])]{ + +When @scheme[to-paragraph] and variants encounter a +@scheme[shaped-parens] structure, it is typeset like a syntax object +that has a @scheme['paren-shape] property with value @scheme[shape].} + + +@defstruct[just-context ([val any/c] + [context syntax?])]{ + +When @scheme[to-paragraph] and variants encounter a +@scheme[just-context] structure, it is typeset using the +source-location information of @scheme[val] just the lexical context +of @scheme[ctx].} + + +@defstruct[literal-syntax ([stx any/c])]{ + +When @scheme[to-paragraph] and variants encounter a +@scheme[literal-syntax] structure, it is typeset as the string form of +@scheme[stx]. This can be used to typeset a syntax-object value in the +way that the default printer would represent the value.} + + +@defproc[(element-id-transformer? [v any/c]) boolean?]{ + +Provided @scheme[for-syntax]; returns @scheme[#t] if @scheme[v] is an +@tech{element transformer} created by +@scheme[make-element-id-transformer], @scheme[#f] otherwise.} + + +@defproc[(make-element-id-transformer [proc (syntax? . -> . syntax?)]) + element-id-transformer?]{ + +Provided @scheme[for-syntax]; creates an @deftech{element +transformer}. When an identifier has a transformer binding to an +@tech{element transformer}, then forms generated by +@scheme[define-code] (including @scheme[scheme] and +@scheme[schemeblock]) typeset the identifier by applying the +@scheme[proc] to the identifier. The result must be an expression +whose value, typically an @scheme[element], is passed on to functions +like @scheme[to-paragraph] .} + +@defproc[(variable-id? [v any/c]) boolean?]{ + +Provided @scheme[for-syntax]; returns @scheme[#t] if @scheme[v] is an +@tech{element transformer} created by @scheme[make-variable-id], +@scheme[#f] otherwise.} + + +@defproc[(make-variable-id [sym (or/c symbol? identifier?)]) + variable-id?]{ + +Provided @scheme[for-syntax]; like @scheme[element-id-transformer] for +a transformer that produces @scheme[sym] typeset as a variable (like +@scheme[schemevarfont]).} From 88075e2e504b1e157dffd05ede8e07b56183e7dd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Feb 2009 14:20:24 +0000 Subject: [PATCH 009/142] a commit to show something to stevie svn: r13692 --- collects/games/chat-noir/chat-noir-literate.ss | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 928133a95c..564f2c0c6b 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -172,7 +172,8 @@ flattens the nested lists and the @chunk[ (define/contract (empty-board board-size) - (-> natural-number/c (listof cell?)) + (-> (and/c natural-number/c odd? (>=/c 3)) + (listof cell?)) (filter (not-corner? board-size) (apply @@ -187,7 +188,9 @@ flattens the nested lists and the false)))))))) (define/contract ((not-corner? board-size) c) - (-> natural-number/c (-> cell? boolean?)) + (-> (and/c natural-number/c odd? (>=/c 3)) + (-> cell? + boolean?)) (not (and (= 0 (posn-x (cell-p c))) (or (= 0 (posn-y (cell-p c))) (= (- board-size 1) @@ -221,7 +224,9 @@ cats initial position as the center spot on the board. @chunk[ - (define (empty-world board-size) + (define/contract (empty-world board-size) + (-> (and/c natural-number/c odd? (>=/c 3)) + world?) (make-world (empty-board board-size) (make-posn (quotient board-size 2) (quotient board-size 2)) @@ -318,7 +323,11 @@ and that @scheme[posn]'s distance. @chunk[ - (define (bfs queue dist-table) + (define/contract (bfs queue dist-table) + (-> (listof (vector/c (or/c 'boundary posn?) natural-number/c)) + hash? + hash?) + 'neighbors/w-is-a-free-variable-here-and-I-would-like-it-to-have-a-contract-that-appears-here (cond [(empty? queue) dist-table] [else From 7920cc48a3b6f9ec34cad1d327a1da4472523ffe Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 14:30:00 +0000 Subject: [PATCH 010/142] Clean up define/contract's description a bit, and avoid leaning on with-contract as much. svn: r13693 --- collects/scribblings/reference/contracts.scrbl | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 0b5dfafcf6..c254ba9cbf 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -694,15 +694,16 @@ within the @scheme[with-contract] @scheme[body] will use the @defform*[[(define/contract id contract-expr init-value-expr) (define/contract (head args) contract-expr body ...+)]]{ Works like @scheme[define], except that the contract -@scheme[contract-expr] is attached to the bound value. +@scheme[contract-expr] is attached to the bound value. For the +definition of @scheme[head] and @scheme[args], see @scheme[define]. -The @scheme[define/contract] form treats individual definitions as -units of blame. The definition itself is responsible for positive -(co-variant) positions of the contract and each reference to -@scheme[id] (including those in the initial value expression) must -meet the negative positions of the contract. It is equivalent to -wrapping a single @scheme[define] with a @scheme[with-contract] form -that pairs the @scheme[contract-expr] with the bound identifier.} +The @scheme[define/contract] form treats the individual definition as +a contract region. The definition itself is responsible for positive +(co-variant) positions of the contract and references to +@scheme[id] outside of the definition must meet the negative +positions of the contract. Since the contract boundary is +between the definition and the surrounding context, references to +@scheme[id] inside the @scheme[define/contract] form are not checked.} @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) From 316f48c8e1bd925354b1bddff25e2797f00be5d8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 14:55:55 +0000 Subject: [PATCH 011/142] Add a guide reference here. svn: r13694 --- collects/scribblings/reference/units.scrbl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index bbea44dcbe..1f3cf4eb6b 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -19,6 +19,8 @@ @title[#:tag "mzlib:unit" #:style 'toc]{Units} +@guideintro["units"]{units} + @deftech{Units} organize a program into separately compilable and reusable components. The imports and exports of a unit are grouped into a @deftech{signature}, which can include ``static'' information From e0e6fcb465fe35d425aaf06510c5b3ed5ff1de59 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 15:02:07 +0000 Subject: [PATCH 012/142] Add unicode longmapsto. svn: r13695 --- collects/redex/private/pict.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss index 07a46343aa..89bc5c0e89 100644 --- a/collects/redex/private/pict.ss +++ b/collects/redex/private/pict.ss @@ -363,6 +363,7 @@ [(~~>) (curvy-arrow-pict)] [(~>) (short-curvy-arrow-pict)] [(:->) (basic-text "\u21a6" (default-style))] + [(:-->) (basic-text "\u27fc" (default-style))] [(c->) (basic-text "\u21aa" (default-style))] [(-->>) (basic-text "\u21a0" (default-style))] [(>--) (basic-text "\u291a" (default-style))] From 941a8935aa15954607a9e9437caf7293e5da18f8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Feb 2009 15:22:55 +0000 Subject: [PATCH 013/142] remove unneeded dependency of framework on parts of Scribble; Redex doc repairs; add #:style? argument to deftech svn: r13696 --- collects/framework/private/text.ss | 6 +-- collects/redex/redex.scrbl | 57 ++++++++++------------ collects/scribble/private/manual-tech.ss | 6 ++- collects/scribblings/scribble/manual.scrbl | 8 ++- 4 files changed, 38 insertions(+), 39 deletions(-) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index cce4a88ec9..63711e616a 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -21,11 +21,7 @@ WARNING: printf is rebound in the body of the unit to always (prefix-in srfi1: srfi/1)) (require setup/xref scribble/xref - scribble/struct - scribble/manual-struct - scribble/decode - scribble/basic - (prefix-in s/m: scribble/manual)) + scribble/manual-struct) (import mred^ [prefix icon: framework:icon^] diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index c9242e3389..ddacfc7c34 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -16,7 +16,7 @@ [(_ arg) (identifier? #'arg) (let ([as (symbol->string (syntax-e #'arg))]) - #`(index '("Redex Pattern" #,as) (deftech #,as)))])) + #`(index '("Redex Pattern" #,as) (deftech #:style? #f @scheme[arg])))])) @(define-syntax (pattech stx) (syntax-case stx () @@ -27,8 +27,8 @@ @(define-syntax (ttpattern stx) (syntax-case stx () [(_ args ...) - #'((tech (tt "pattern")) args ...)] - [x (identifier? #'x) #'(tech (tt "pattern"))])) + #'((tech (schemevarfont "pattern")) args ...)] + [x (identifier? #'x) #'(tech (schemevarfont "pattern"))])) @(define-syntax (pattern stx) (syntax-case stx () @@ -39,8 +39,8 @@ @(define-syntax (tttterm stx) (syntax-case stx () [(_ args ...) - #'((tech (tt "term")) args ...)] - [x (identifier? #'x) #'(tech (tt "term"))])) + #'((tech (schemevarfont "term")) args ...)] + [x (identifier? #'x) #'(tech (schemevarfont "term"))])) @(define-syntax (tterm stx) (syntax-case stx () @@ -372,7 +372,7 @@ the visible representation of terms. The grammar of @deftech{term}s is (note that an ellipsis stands for repetition unless otherwise indicated): -@(schemegrammar* #:literals (in-hole hole) +@(schemegrammar* #:literals (in-hole hole unquote unquote-splicing) [term identifier (term-sequence ...) ,scheme-expression @@ -387,28 +387,28 @@ stands for repetition unless otherwise indicated): @itemize{ -@item{A term written @tt{identifier} is equivalent to the +@item{A term written @scheme[_identifier] is equivalent to the corresponding symbol, unless the identifier is bound by @scheme[term-let] (or in a @|pattern| elsewhere) or is @tt{hole} (as below). } -@item{A term written @tt{(term-sequence ...)} constructs a list of +@item{A term written @scheme[(_term-sequence ...)] constructs a list of the terms constructed by the sequence elements.} -@item{A term written @scheme[,scheme-expression] evaluates the +@item{A term written @scheme[,_scheme-expression] evaluates the @scheme[scheme-expression] and substitutes its value into the term at that point.} -@item{A term written @scheme[,@scheme-expression] evaluates the +@item{A term written @scheme[,@_scheme-expression] evaluates the @scheme[scheme-expression], which must produce a list. It then splices the contents of the list into the expression at that point in the sequence.} -@item{A term written @tt{(in-hole @|tttterm| @|tttterm|)} - is the dual to the @pattern `in-hole' -- it accepts +@item{A term written @scheme[(in-hole @|tttterm| @|tttterm|)] + is the dual to the @pattern @scheme[in-hole] -- it accepts a context and an expression and uses @scheme[plug] to combine them.} -@item{A term written @tt{hole} produces a hole.} +@item{A term written @scheme[hole] produces a hole.} @item{A term written as a literal boolean or a string produces the boolean or the string.} @@ -418,13 +418,11 @@ produces the boolean or the string.} This form is used for construction of a term. - in -the right-hand sides of reductions. It behaves similarly to -quasiquote except for a few special forms that are -recognized (listed below) and that names bound by @scheme[term-let] are -implicitly substituted with the values that those names were -bound to, expanding ellipses as in-place sublists (in the -same manner as syntax-case patterns). +It behaves similarly to @scheme[quasiquote], except for a few special +forms that are recognized (listed below) and that names bound by +@scheme[term-let] are implicitly substituted with the values that +those names were bound to, expanding ellipses as in-place sublists (in +the same manner as syntax-case patterns). For example, @@ -461,16 +459,15 @@ the id pattern to the appropriate value (described below). These bindings are then accessible to the `term' syntactic form. -Note that each @scheme[ellipsis] should be the literal -symbol consisting of three dots (and the ... elsewhere -indicates repetition as usual). If @scheme[tl-pat] is an identifier, -it matches any value and binds it to the identifier, for use -inside @scheme[term]. If it is a list, it matches only if the value -being matched is a list value and only if every subpattern -recursively matches the corresponding list element. There -may be a single ellipsis in any list pattern; if one is -present, the pattern before the ellipses may match multiple -adjacent elements in the list value (possibly none). +Note that each ellipsis should be the literal symbol consisting of +three dots (and the ... elsewhere indicates repetition as usual). If +@scheme[tl-pat] is an identifier, it matches any value and binds it to +the identifier, for use inside @scheme[term]. If it is a list, it +matches only if the value being matched is a list value and only if +every subpattern recursively matches the corresponding list +element. There may be a single ellipsis in any list pattern; if one is +present, the pattern before the ellipses may match multiple adjacent +elements in the list value (possibly none). This form is a lower-level form in Redex, and not really designed to be used directly. If you want a @scheme[let]-like form that uses diff --git a/collects/scribble/private/manual-tech.ss b/collects/scribble/private/manual-tech.ss index d2d386ced4..5cb7d417b2 100644 --- a/collects/scribble/private/manual-tech.ss +++ b/collects/scribble/private/manual-tech.ss @@ -15,8 +15,10 @@ [s (regexp-replace* #px"[-\\s]+" s " ")]) (make-elem style c (list 'tech (doc-prefix doc s))))) -(define (deftech . s) - (let* ([e (apply defterm s)] +(define (deftech #:style? [style? #t] . s) + (let* ([e (if style? + (apply defterm s) + (make-element #f (decode-content s)))] [t (*tech make-target-element #f #f (list e))]) (make-index-element #f (list t) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 6b97fcad28..4f94f26332 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -929,7 +929,8 @@ The @tech{decode}d @scheme[pre-content] is hyperlinked to @scheme[t], which is normally defined using @scheme[elemtag].} -@defproc[(deftech [pre-content any/c] ...) element?]{ +@defproc[(deftech [pre-content any/c] ... + [#:style? style? any/c #t]) element?]{ Produces an element for the @tech{decode}d @scheme[pre-content], and also defines a term that can be referenced elsewhere using @@ -952,7 +953,10 @@ as follows: These normalization steps help support natural-language references that differ slightly from a defined form. For example, a definition of -``bananas'' can be referenced with a use of ``banana''.} +``bananas'' can be referenced with a use of ``banana''. + +If @scheme[style?] is true, then @scheme[defterm] is used on +@scheme[pre-content].} @defproc[(tech [pre-content any/c] ... [#:doc module-path (or/c module-path? false/c) #f]) From e21ecbe0748e6b3098da3e7e4d9ae61e12880a67 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Feb 2009 15:41:43 +0000 Subject: [PATCH 014/142] a little more progress on the essay -- also started using define/contract instead of define svn: r13697 --- .../games/chat-noir/chat-noir-literate.ss | 422 ++++++++++-------- 1 file changed, 244 insertions(+), 178 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 564f2c0c6b..cdf27fcc15 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,5 +1,12 @@ #reader "literate-reader.ss" +@;{ +The command to build this: + +scribble ++xref-in setup/xref load-collections-xref --htmls chat-noir-doc.ss + +} + @title{Chat Noir} The goal of Chat Noir is to stop the cat from escaping the board. Each @@ -38,7 +45,9 @@ and some code that builds an initial world and starts the game. (for-syntax scheme/base)) (require htdp/world lang/posn scheme/contract) - + + graph> + ] @@ -47,7 +56,9 @@ Each section also comes with a series of test cases that are collected into the @chunk[ - + + graph-tests> + ] Each test case uses either @scheme[test], a simple form that accepts two @@ -235,9 +246,7 @@ cats initial position as the center spot on the board. false false))] - - -@section{Graph} +@section{Breadth-first Search} The cat's move decision is based on a breadth-first search of a graph. The graph's nodes are the cells on the board plus a special @@ -247,33 +256,23 @@ there are edges between each pair of adjacent cells, unless one of the cells is blocked, in which case it has no edges at all (even to the boundary). +This section describes the implementation of the breadth-first search, leaving +details of how the graph connectivity is computed from the board to the next section. + The code for the breadth-first search is organized into X parts .... -@chunk[ +@chunk[ + ] - - - - - - ] - -@chunk[ - +@chunk[ - - - - - - - ] + ] The breadth-first function constructs a @scheme[distance-map], which is a list of @scheme[dist-cell] structs: @@ -327,7 +326,6 @@ and that @scheme[posn]'s distance. (-> (listof (vector/c (or/c 'boundary posn?) natural-number/c)) hash? hash?) - 'neighbors/w-is-a-free-variable-here-and-I-would-like-it-to-have-a-contract-that-appears-here (cond [(empty? queue) dist-table] [else @@ -356,12 +354,14 @@ expression, and update the @scheme[dist-table] with the distance to this node. The @scheme[build-bfs-table] function packages up @scheme[bfs] -function. It accepts a @tt{world} and an initial position +function. It accepts a @scheme[world] and an initial position and returns a @scheme[distance-table]. @chunk[ - (define (build-bfs-table world init-point) + (define/contract (build-bfs-table world init-point) + (-> world? (or/c 'boundary posn?) + (listof dist-cell?)) (define neighbors/w (neighbors world)) @@ -427,8 +427,10 @@ list of the cells that are on the boundary (and not blocked). Then it returns a function that is specialized to those values. @chunk[ -;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) -(define (neighbors w) +(define/contract (neighbors w) + (-> world? + (-> (or/c 'boundary posn?) + (listof (or/c 'boundary posn?)))) (define blocked (map cell-p (filter (lambda (c) @@ -459,8 +461,10 @@ we know that @scheme[p] must have been on the boundary, so we add @scheme['boundary] to the result list. @chunk[ -;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) -(define (neighbors-blocked/boundary blocked boundary-cells size p) +(define/contract (neighbors-blocked/boundary blocked boundary-cells size p) + (-> (listof posn?) (listof posn?) natural-number/c (or/c 'boundary posn?) + (listof (or/c 'boundary posn?))) + (cond [(member p blocked) '()] @@ -481,6 +485,97 @@ we know that @scheme[p] must have been on the boundary, so we add (cons 'boundary in-bounds)]))]))] +@section{Board to Graph Functions} + +There are three functions that build the basic graph structure +from a board. + +@chunk[graph> + + + ] + +@chunk[graph-tests> + + + ] + +The first function is @scheme[adjacent]. It consumes a +@scheme[posn] and returns six @scheme[posn]s that +indicate what the neighbors are, without consideration +of the size of the board (or the missing corner pieces). + +For example, these are the @scheme[posn]s that are adjacent +to @scheme[(make-posn 0 1)]. + +@chunk[ + (test (adjacent (make-posn 0 1)) + (list (make-posn 0 0) + (make-posn 1 0) + (make-posn -1 1) + (make-posn 1 1) + (make-posn 0 2) + (make-posn 1 2)))] + +The adjacent function has two main cases; first when the +@scheme[y] coordinate of the @scheme[posn] is even and +second when it is odd. In each case, it is just a matter +of looking at the board and calculating coordinate offsets. + +@chunk[ + (define/contract (adjacent p) + (-> posn? + (and/c (listof posn?) + (lambda (l) (= 6 (length l))))) + (local [(define x (posn-x p)) + (define y (posn-y p))] + (cond + [(even? y) + (list (make-posn (- x 1) (- y 1)) + (make-posn x (- y 1)) + (make-posn (- x 1) y) + (make-posn (+ x 1) y) + (make-posn (- x 1) (+ y 1)) + (make-posn x (+ y 1)))] + [else + (list (make-posn x (- y 1)) + (make-posn (+ x 1) (- y 1)) + (make-posn (- x 1) y) + (make-posn (+ x 1) y) + (make-posn x (+ y 1)) + (make-posn (+ x 1) (+ y 1)))])))] + +The @scheme[on-boundary?] function returns @scheme[true] when +the posn would be on the boundary of a board of size +@scheme[board-size]. Note that this function does not +have to special case the missing @scheme[posn]s from the corners. + +@chunk[ + (define/contract (on-boundary? p board-size) + (-> posn? natural-number/c + boolean?) + (or (= (posn-x p) 0) + (= (posn-y p) 0) + (= (posn-x p) (- board-size 1)) + (= (posn-y p) (- board-size 1))))] + +The @scheme[in-bounds?] function returns @scheme[true] +when the @scheme[posn] is actually on the board, meaning +that the coordinates of the @scheme[posn] are within the +board's size, and that the @scheme[posn] is not one +of the two corners that have been removed. + +@chunk[ + (define/contract (in-bounds? p board-size) + (-> posn? natural-number/c + boolean?) + (and (<= 0 (posn-x p) (- board-size 1)) + (<= 0 (posn-y p) (- board-size 1)) + (not (equal? p (make-posn 0 0))) + (not (equal? p (make-posn 0 (- board-size 1))))))] + + + @chunk[ ;; lookup-in-table : distance-map posn -> number or '∞ ;; looks for the distance as recorded in the table t, @@ -504,165 +599,85 @@ we know that @scheme[p] must have been on the boundary, so we add (make-posn 1 2)) '∞)] +@section{The Cat's Path} + +@chunk[ + + <+/f>] + +@chunk[ + + <+/f-tests>] @chunk[ ;; on-cats-path? : world -> posn -> boolean ;; returns true when the posn is on the shortest path ;; from the cat to the edge of the board, in the given world -(define (on-cats-path? w) - (cond - [(world-h-down? w) - (let () - (define edge-distance-map (build-bfs-table w 'boundary)) - (define cat-distance-map (build-bfs-table w (world-cat w))) - (define cat-distance - (lookup-in-table edge-distance-map (world-cat w))) - (cond - [(equal? cat-distance '∞) - (lambda (p) false)] - [else - (lambda (p) - (equal? (+/f (lookup-in-table cat-distance-map p) - (lookup-in-table edge-distance-map p)) - cat-distance))]))] - [else - (lambda (p) false)]))] + (define (on-cats-path? w) + (cond + [(world-h-down? w) + (let () + (define edge-distance-map (build-bfs-table w 'boundary)) + (define cat-distance-map (build-bfs-table w (world-cat w))) + (define cat-distance + (lookup-in-table edge-distance-map (world-cat w))) + (cond + [(equal? cat-distance '∞) + (lambda (p) false)] + [else + (lambda (p) + (equal? (+/f (lookup-in-table cat-distance-map p) + (lookup-in-table edge-distance-map p)) + cat-distance))]))] + [else + (lambda (p) false)]))] @chunk[ -(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) true)) - (make-posn 1 0)) - true) -(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) false)) - (make-posn 1 0)) - false) -(test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) true)) - (make-posn 2 1)) - false) -(test ((on-cats-path? - (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 0 0) - true)) - (make-posn 0 1)) - false)] + (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) true)) + (make-posn 1 0)) + true) + (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) false)) + (make-posn 1 0)) + false) + (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) true)) + (make-posn 2 1)) + false) + (test ((on-cats-path? + (make-world (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn 0 0) + true)) + (make-posn 0 1)) + false)] + +@chunk[<+/f> + (define (+/f x y) + (cond + [(or (equal? x '∞) (equal? y '∞)) + '∞] + [else + (+ x y)]))] + +@chunk[<+/f-tests> + (test (+/f '∞ '∞) '∞) + (test (+/f '∞ 1) '∞) + (test (+/f 1 '∞) '∞) + (test (+/f 1 2) 3)] -@chunk[ -;; adjacent : posn -> (listof posn) -;; returns a list of the posns that are adjacent to -;; `p' on an infinite hex grid -(define (adjacent p) - (local [(define x (posn-x p)) - (define y (posn-y p))] - (cond - [(even? y) - (list (make-posn (- x 1) (- y 1)) - (make-posn x (- y 1)) - (make-posn (- x 1) y) - (make-posn (+ x 1) y) - (make-posn (- x 1) (+ y 1)) - (make-posn x (+ y 1)))] - [else - (list (make-posn x (- y 1)) - (make-posn (+ x 1) (- y 1)) - (make-posn (- x 1) y) - (make-posn (+ x 1) y) - (make-posn x (+ y 1)) - (make-posn (+ x 1) (+ y 1)))])))] - -@chunk[ -(test (adjacent (make-posn 1 1)) - (list (make-posn 1 0) - (make-posn 2 0) - (make-posn 0 1) - (make-posn 2 1) - (make-posn 1 2) - (make-posn 2 2))) -(test (adjacent (make-posn 2 2)) - (list (make-posn 1 1) - (make-posn 2 1) - (make-posn 1 2) - (make-posn 3 2) - (make-posn 1 3) - (make-posn 2 3)))] - -@chunk[ -;; on-boundary? : posn number -> boolean -(define (on-boundary? p board-size) - (or (= (posn-x p) 0) - (= (posn-y p) 0) - (= (posn-x p) (- board-size 1)) - (= (posn-y p) (- board-size 1))))] - -@chunk[ -(test (on-boundary? (make-posn 0 1) 13) true) -(test (on-boundary? (make-posn 1 0) 13) true) -(test (on-boundary? (make-posn 12 1) 13) true) -(test (on-boundary? (make-posn 1 12) 13) true) -(test (on-boundary? (make-posn 1 1) 13) false) -(test (on-boundary? (make-posn 10 10) 13) false)] - -@chunk[ - -;; in-bounds? : posn number -> boolean -(define (in-bounds? p board-size) - (and (<= 0 (posn-x p) (- board-size 1)) - (<= 0 (posn-y p) (- board-size 1)) - (not (equal? p (make-posn 0 0))) - (not (equal? p (make-posn 0 (- board-size 1))))))] - -@chunk[ -(test (in-bounds? (make-posn 0 0) 11) false) -(test (in-bounds? (make-posn 0 1) 11) true) -(test (in-bounds? (make-posn 1 0) 11) true) -(test (in-bounds? (make-posn 10 10) 11) true) -(test (in-bounds? (make-posn 0 -1) 11) false) -(test (in-bounds? (make-posn -1 0) 11) false) -(test (in-bounds? (make-posn 0 11) 11) false) -(test (in-bounds? (make-posn 11 0) 11) false) -(test (in-bounds? (make-posn 10 0) 11) true) -(test (in-bounds? (make-posn 0 10) 11) false)] - -@chunk[ -;; <=/f : (number or '∞) (number or '∞) -> boolean -(define (<=/f a b) - (cond - [(equal? b '∞) true] - [(equal? a '∞) false] - [else (<= a b)])) - -(define (+/f x y) - (cond - [(or (equal? x '∞) (equal? y '∞)) - '∞] - [else - (+ x y)]))] - -@chunk[ -(test (<=/f 1 2) true) -(test (<=/f 2 1) false) -(test (<=/f '∞ 1) false) -(test (<=/f 1 '∞) true) -(test (<=/f '∞ '∞) true) - -(test (+/f '∞ '∞) '∞) -(test (+/f '∞ 1) '∞) -(test (+/f 1 '∞) '∞) -(test (+/f 1 2) 3)] - @section{Tests} @chunk[ @@ -928,6 +943,44 @@ we know that @scheme[p] must have been on the boundary, so we add (make-posn 1 0)) (list 'boundary (make-posn 2 0) (make-posn 0 1)))] +@chunk[ + (test (adjacent (make-posn 1 1)) + (list (make-posn 1 0) + (make-posn 2 0) + (make-posn 0 1) + (make-posn 2 1) + (make-posn 1 2) + (make-posn 2 2))) + (test (adjacent (make-posn 2 2)) + (list (make-posn 1 1) + (make-posn 2 1) + (make-posn 1 2) + (make-posn 3 2) + (make-posn 1 3) + (make-posn 2 3)))] + + +@chunk[ + (test (on-boundary? (make-posn 0 1) 13) true) + (test (on-boundary? (make-posn 1 0) 13) true) + (test (on-boundary? (make-posn 12 1) 13) true) + (test (on-boundary? (make-posn 1 12) 13) true) + (test (on-boundary? (make-posn 1 1) 13) false) + (test (on-boundary? (make-posn 10 10) 13) false)] + + +@chunk[ + (test (in-bounds? (make-posn 0 0) 11) false) + (test (in-bounds? (make-posn 0 1) 11) true) + (test (in-bounds? (make-posn 1 0) 11) true) + (test (in-bounds? (make-posn 10 10) 11) true) + (test (in-bounds? (make-posn 0 -1) 11) false) + (test (in-bounds? (make-posn -1 0) 11) false) + (test (in-bounds? (make-posn 0 11) 11) false) + (test (in-bounds? (make-posn 11 0) 11) false) + (test (in-bounds? (make-posn 10 0) 11) true) + (test (in-bounds? (make-posn 0 10) 11) false)] + @section{Everything Else} @@ -1709,6 +1762,19 @@ we know that @scheme[p] must have been on the boundary, so we add (list '∞ '∞)) false) +;; <=/f : (number or '∞) (number or '∞) -> boolean +(define (<=/f a b) + (cond + [(equal? b '∞) true] + [(equal? a '∞) false] + [else (<= a b)])) + +(test (<=/f 1 2) true) +(test (<=/f 2 1) false) +(test (<=/f '∞ 1) false) +(test (<=/f 1 '∞) true) +(test (<=/f '∞ '∞) true) + ;; add-obstacle : board number number -> board (define (add-obstacle board x y) (cond From 560836a8048d3b55f8cdb6b251b0abf708d7a6bf Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 16:14:12 +0000 Subject: [PATCH 015/142] Draw :-> and :--> ourselves, similar to --> and friends. svn: r13698 --- collects/redex/private/arrow.ss | 13 ++++++++++++- collects/redex/private/pict.ss | 12 ++++++++++-- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/collects/redex/private/arrow.ss b/collects/redex/private/arrow.ss index 023f748cb6..c8dad8c4a5 100644 --- a/collects/redex/private/arrow.ss +++ b/collects/redex/private/arrow.ss @@ -7,7 +7,7 @@ (provide/contract [make-arrow-pict (-> string? - (symbols 'curvy 'straight 'straight-double) + (symbols 'curvy 'straight 'straight-double 'map) symbol? number? (-> pict?))]) @@ -71,6 +71,17 @@ (case style [(curvy) (send dc draw-path path dx dy)] + [(map) + (send dc draw-line + dx + (- (+ dy line-pos) (/ head-height 2)) + dx + (+ (+ dy line-pos) (/ head-height 2))) + (send dc draw-line + dx + (+ dy line-pos) + (+ dx w) + (+ dy line-pos))] [(straight) (send dc draw-line dx diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss index 89bc5c0e89..43d3e8edff 100644 --- a/collects/redex/private/pict.ss +++ b/collects/redex/private/pict.ss @@ -344,6 +344,8 @@ (define short-curvy-arrow-pict (mk-arrow-pict "m" 'curvy)) (define double-arrow-pict (mk-arrow-pict "xxx" 'straight-double)) (define short-double-arrow-pict (mk-arrow-pict "m" 'straight-double)) +(define map-arrow-pict (mk-arrow-pict "m" 'map)) +(define long-map-arrow-pict (mk-arrow-pict "xxx" 'map)) (define user-arrow-table (make-hasheq)) (define (set-arrow-pict! arr thunk) @@ -362,8 +364,14 @@ [(>->) (basic-text "\u21a3" (default-style))] [(~~>) (curvy-arrow-pict)] [(~>) (short-curvy-arrow-pict)] - [(:->) (basic-text "\u21a6" (default-style))] - [(:-->) (basic-text "\u27fc" (default-style))] + [(:->) + (if STIX? + (basic-text "\u21a6" (default-style)) + (map-arrow-pict))] + [(:-->) + (if STIX? + (basic-text "\u27fc" (default-style)) + (long-map-arrow-pict))] [(c->) (basic-text "\u21aa" (default-style))] [(-->>) (basic-text "\u21a0" (default-style))] [(>--) (basic-text "\u291a" (default-style))] From 64a68db15d0389fd27442d87e12f0ee959d5036b Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 18:18:53 +0000 Subject: [PATCH 016/142] Initial attempt at free var contracts. Needs a little more work, but might handle Robby's use cases. svn: r13700 --- collects/scheme/private/contract.ss | 182 ++++++++++++------ .../scribblings/reference/contracts.scrbl | 13 +- 2 files changed, 135 insertions(+), 60 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 185513882b..6b1805c2e7 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -88,29 +88,41 @@ improve method arity mismatch contract violation error messages? (raise-syntax-error 'define/contract "no body after contract" define-stx)] - [(_ name contract-expr expr) - (identifier? #'name) - (syntax/loc define-stx - (with-contract #:type definition name - ([name contract-expr]) - (define name expr)))] - [(_ name contract-expr expr0 expr ...) - (identifier? #'name) + [(_ name+arg-list contract #:freevars args . body) + (identifier? #'args) (raise-syntax-error 'define/contract - "multiple expressions after identifier and contract" - define-stx)] + "expected list of identifier/contract pairs" + #'args)] + [(_ name+arg-list contract #:freevars (arg ...) #:freevar x c . body) + (syntax/loc define-stx + (define/contract name+arg-list contract #:freevars (arg ... [x c]) #:freevar x c . body))] + [(_ name+arg-list contract #:freevar x c . body) + (syntax/loc define-stx + (define/contract name+arg-list contract #:freevars () #:freevar x c . body))] + [(_ name+arg-list contract #:freevars args body0 body ...) + (begin + (when (and (identifier? #'name+arg-list) + (not (null? (syntax->list #'(body ...))))) + (raise-syntax-error 'define/contract + "multiple expressions after identifier and contract" + #'(body ...))) + (let-values ([(name body-expr) + (if (identifier? #'name+arg-list) + (values #'name+arg-list #'body0) + (normalize-definition + (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list + #'body0 #'(body ...))) + #'lambda #t #t))]) + (with-syntax ([name name] + [body-expr body-expr]) + (syntax/loc define-stx + (with-contract #:type function name + ([name (verify-contract 'define/contract contract)]) + #:freevars args + (define name body-expr))))))] [(_ name+arg-list contract body0 body ...) - (let-values ([(name lam-expr) - (normalize-definition - (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list - #'body0 #'(body ...))) - #'lambda #t #t)]) - (with-syntax ([name name] - [lam-expr lam-expr]) - (syntax/loc define-stx - (with-contract #:type function name - ([name (verify-contract 'define/contract contract)]) - (define name lam-expr)))))])) + (syntax/loc define-stx + (define/contract name+arg-list contract #:freevars () body0 body ...))])) @@ -221,10 +233,7 @@ improve method arity mismatch contract violation error messages? (syntax/loc stx (with-contract-helper marker blame-stx ((p c) ...) (u ...) sub ... body ...))] [(define-values (id ...) expr) - (let*-values ([(marker-f) (let ([marker (syntax-e #'marker)]) - (lambda (stx) - (syntax-local-introduce - (marker (syntax-local-introduce stx)))))] + (let*-values ([(marker-f) (syntax-e #'marker)] [(used-p/cs used-us unused-p/cs unused-us) (partition-ids (syntax->list #'(id ...)) (map syntax->list (syntax->list #'((p c) ...))) @@ -269,10 +278,7 @@ improve method arity mismatch contract violation error messages? (with-contract-helper marker blame-stx #,unused-p/cs #,unused-us body ...)))))] [(splicing-syntax-parameterize bindings . ssp-body) - (let* ([marker-f (let ([marker (syntax-e #'marker)]) - (lambda (stx) - (syntax-local-introduce - (marker (syntax-local-introduce stx)))))] + (let* ([marker-f (syntax-e #'marker)] [expanded-ssp (local-expand (quasisyntax/loc expanded-body0 (splicing-syntax-parameterize bindings . #,(marker-f #'ssp-body))) @@ -282,15 +288,12 @@ improve method arity mismatch contract violation error messages? (begin #,expanded-ssp (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))] [else - (let*-values ([(marker-f) (let ([marker (syntax-e #'marker)]) - (lambda (stx) - (syntax-local-introduce - (marker (syntax-local-introduce stx)))))]) + (let*-values ([(marker-f) (syntax-e #'marker)]) (quasisyntax/loc stx (begin #,(marker-f expanded-body0) (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))]))])) -(define-for-syntax (check-and-split-with-contract-args args) +(define-for-syntax (check-and-split-with-contracts single-allowed? args) (let loop ([args args] [unprotected null] [protected null] @@ -299,6 +302,10 @@ improve method arity mismatch contract violation error messages? [(null? args) (values unprotected protected protections)] [(identifier? (car args)) + (unless single-allowed? + (raise-syntax-error 'with-contract + "expected (identifier contract)" + (car args))) (loop (cdr args) (cons (car args) unprotected) protected @@ -316,21 +323,72 @@ improve method arity mismatch contract violation error messages? (cons (second l) protections)))] [else (raise-syntax-error 'with-contract - "expected an identifier or (identifier contract)" + (format "expected ~a(identifier contract)" + (if single-allowed? "an identifier or " "")) (car args))]))) +(define-for-syntax (make-free-var-transformer fv ctc pos-blame neg-blame) + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'with-contract + "cannot set! a contracted variable" + stx + (syntax id))] + [(f arg ...) + (quasisyntax/loc stx + ((let ([f (-contract #,ctc + #,fv + #,pos-blame + #,neg-blame + #,(id->contract-src-info fv))]) + f) arg ...))] + [ident + (identifier? (syntax ident)) + (quasisyntax/loc stx + (let ([ident (-contract #,ctc + #,fv + #,pos-blame + #,neg-blame + #,(id->contract-src-info fv))]) + ident))])))) + (define-syntax (with-contract stx) (when (eq? (syntax-local-context) 'expression) (raise-syntax-error 'with-contract "used in expression context" stx)) (syntax-case stx () - [(_ #:type type blame (arg ...) body0 . body) + [(_ #:type type etc ...) + (not (identifier? #'type)) + (raise-syntax-error 'with-contract + "expected identifier for type" + #'type)] + [(_ #:type type args etc ...) + (not (identifier? #'args)) + (raise-syntax-error 'with-contract + "expected identifier for blame" + #'args)] + [(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body) + (identifier? #'x) + (syntax/loc stx + (with-contract #:type type blame (arg ...) #:freevars (fv ... [x c]) . body))] + [(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body) + (raise-syntax-error 'with-contract + "use of #:freevar with non-identifier" + #'x)] + [(_ #:type type blame (arg ...) #:freevars (fv ...) body0 . body) (and (identifier? #'blame) (identifier? #'type)) - (let*-values ([(marker) (make-syntax-introducer)] + (let*-values ([(marker) (let ([marker (make-syntax-introducer)]) + (λ (x) + (syntax-local-introduce + (marker (syntax-local-introduce x)))))] + [(no-need free-vars free-ctcs) + (check-and-split-with-contracts #f (syntax->list #'(fv ...)))] [(unprotected protected protections) - (check-and-split-with-contract-args (syntax->list #'(arg ...)))]) + (check-and-split-with-contracts #t (syntax->list #'(arg ...)))]) (begin (let ([dupd-id (check-duplicate-identifier (append unprotected protected))]) (when dupd-id @@ -338,35 +396,47 @@ improve method arity mismatch contract violation error messages? "identifier appears twice in exports" dupd-id))) (with-syntax ([blame-stx #''(type blame)] + [blame-id (car (generate-temporaries (list #t)))] + [(free-var ...) free-vars] + [(free-var-id ...) (map marker free-vars)] + [(free-ctc-id ...) (map (λ (i) + (marker (a:mangle-id stx "with-contract-contract-id" i))) + free-vars)] + [(free-ctc ...) (map (lambda (c) + (if (a:known-good-contract? c) + c + #`(coerce-contract 'with-contract #,c))) + free-ctcs)] [((p c) ...) (map list protected protections)] [(u ...) unprotected]) (quasisyntax/loc stx - (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) - (with-contract-helper #,marker blame-stx ((p c) ...) (u ...) body0 . body))))))] - [(_ #:type type blame (arg ...) body0 body ...) - (raise-syntax-error 'with-contract - "expected identifier for blame" - #'blame)] + (begin + (define-values (free-ctc-id ...) + (values free-ctc ...)) + (define blame-id + (current-contract-region)) + (define-syntaxes (free-var-id ...) + (values (make-free-var-transformer + (quote-syntax free-var) + (quote-syntax free-ctc-id) + (quote-syntax blame-id) + (quote-syntax blame-stx)) ...)) + (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) + (with-contract-helper #,marker blame-stx ((p c) ...) (u ...) body0 . body)))))))] + [(_ #:type type blame (arg ...) #:freevar x c . body) + (syntax/loc stx + (with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))] + [(_ #:type type blame (arg ...) body0 . body) + (syntax/loc stx + (with-contract #:type type blame (arg ...) #:freevars () body0 . body))] [(_ #:type type blame (arg ...)) - (identifier? #'blame) (raise-syntax-error 'with-contract "empty body" stx)] [(_ #:type type blame bad-args etc ...) - (identifier? #'blame) (raise-syntax-error 'with-contract "expected list of identifier and/or (identifier contract)" #'bad-args)] - [(_ #:type type args etc ...) - (not (identifier? #'args)) - (raise-syntax-error 'with-contract - "expected identifier for blame" - #'args)] - [(_ #:type type etc ...) - (not (identifier? #'type)) - (raise-syntax-error 'with-contract - "expected identifier for type" - #'type)] [(_ #:type type blame) (raise-syntax-error 'with-contract "only blame" diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index c254ba9cbf..acfdd3fca9 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -674,10 +674,14 @@ only used in the contract for the sub-struct's maker, and the selector or mutators for the super-struct are not provided.} @defform/subs[ - (with-contract blame-id (wc-export ...) body ...+) + (with-contract blame-id (wc-export ...) free-var-list body ...+) ([wc-export id - (id contract-expr)])]{ + (id contract-expr)] + [free-var-list + code:blank + (code:line #:freevars ([id contract-expr] ...)) + (code:line #:freevar id contract-expr)])]{ Generates a local contract boundary. The @scheme[contract-expr] form cannot appear in expression position. The @scheme[body] of the form allows definition/expression interleaving like a @scheme[module] @@ -691,11 +695,12 @@ contracts paired with exported @scheme[id]s. Contracts broken within the @scheme[with-contract] @scheme[body] will use the @scheme[blame-id] for their negative position.} -@defform*[[(define/contract id contract-expr init-value-expr) - (define/contract (head args) contract-expr body ...+)]]{ +@defform*[[(define/contract id contract-expr free-var-list init-value-expr) + (define/contract (head args) contract-expr free-var-list body ...+)]]{ Works like @scheme[define], except that the contract @scheme[contract-expr] is attached to the bound value. For the definition of @scheme[head] and @scheme[args], see @scheme[define]. +For the definition of @scheme[free-var-list], see @scheme[with-contract]. The @scheme[define/contract] form treats the individual definition as a contract region. The definition itself is responsible for positive From 792dc70ea6b1644f182024405a0529cb0ae7d3e6 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 18:26:24 +0000 Subject: [PATCH 017/142] Add description of what #:freevars/#:freevar does. svn: r13701 --- collects/scribblings/reference/contracts.scrbl | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index acfdd3fca9..e220d8ee6d 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -693,7 +693,12 @@ exported without a contract. The @scheme[blame-id] is used for the positive positions of contracts paired with exported @scheme[id]s. Contracts broken within the @scheme[with-contract] @scheme[body] will use the -@scheme[blame-id] for their negative position.} +@scheme[blame-id] for their negative position. + +If a free-var-list is given, then any uses of the free variables +inside the @scheme[body] will be protected with contracts that +blame the context of the @scheme[with-contract] form for the positive +positions and the @scheme[with-contract] form for the negative ones.} @defform*[[(define/contract id contract-expr free-var-list init-value-expr) (define/contract (head args) contract-expr free-var-list body ...+)]]{ @@ -708,7 +713,12 @@ a contract region. The definition itself is responsible for positive @scheme[id] outside of the definition must meet the negative positions of the contract. Since the contract boundary is between the definition and the surrounding context, references to -@scheme[id] inside the @scheme[define/contract] form are not checked.} +@scheme[id] inside the @scheme[define/contract] form are not checked. + +If a free-var-list is given, then any uses of the free variables +inside the @scheme[body] will be protected with contracts that +blame the context of the @scheme[with-contract] form for the positive +positions and the @scheme[with-contract] form for the negative ones.} @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) From 5f01ad8412a850069ec20698878ad634ca1bfe70 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 18:27:54 +0000 Subject: [PATCH 018/142] Copy and paste error. svn: r13702 --- collects/scribblings/reference/contracts.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index e220d8ee6d..50cff07d7c 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -717,8 +717,8 @@ between the definition and the surrounding context, references to If a free-var-list is given, then any uses of the free variables inside the @scheme[body] will be protected with contracts that -blame the context of the @scheme[with-contract] form for the positive -positions and the @scheme[with-contract] form for the negative ones.} +blame the context of the @scheme[define/contract] form for the positive +positions and the @scheme[define/contract] form for the negative ones.} @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) From 999d9357ab1cc18b53890e89ee1b04b6ad56adc9 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 19:31:57 +0000 Subject: [PATCH 019/142] * Fix it so we say definition or function in define/contract appropriately again. * Fix horribly complicated and ridiculous version of with-contract with a more streamlined, and more importantly, correct version. svn: r13703 --- collects/scheme/private/contract.ss | 178 ++++++++-------------------- 1 file changed, 52 insertions(+), 126 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 6b1805c2e7..b1027087c0 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -114,10 +114,11 @@ improve method arity mismatch contract violation error messages? #'body0 #'(body ...))) #'lambda #t #t))]) (with-syntax ([name name] - [body-expr body-expr]) + [body-expr body-expr] + [type (if (identifier? #'name+arg-list) 'definition 'function)]) (syntax/loc define-stx - (with-contract #:type function name - ([name (verify-contract 'define/contract contract)]) + (with-contract #:type type name + ([name contract]) #:freevars args (define name body-expr))))))] [(_ name+arg-list contract body0 body ...) @@ -176,122 +177,38 @@ improve method arity mismatch contract violation error messages? #,(id->contract-src-info id))]) ident))]))))) -(define-for-syntax (partition-ids def-ids p/c-pairs unprotected-ids) - (let loop ([ids def-ids] - [used-p/cs null] - [used-us null] - [unused-p/cs p/c-pairs] - [unused-us unprotected-ids]) - (if (null? ids) - (values used-p/cs used-us unused-p/cs unused-us) - (let*-values ([(first-id) (car ids)] - [(matched no-match) - (partition (λ (i) - (bound-identifier=? i first-id)) - unused-us)]) - (if (null? matched) - (let-values ([(matched no-match) - (partition (λ (p/c) - (bound-identifier=? (car p/c) first-id)) - unused-p/cs)]) - (if (null? matched) - (loop (cdr ids) - used-p/cs - used-us - unused-p/cs - unused-us) - (loop (cdr ids) - (append matched used-p/cs) - used-us - no-match - unused-us))) - (loop (cdr ids) - used-p/cs - (append matched used-us) - unused-p/cs - no-match)))))) (define-syntax (with-contract-helper stx) (syntax-case stx () - [(_ marker blame-stx () ()) + [(_ blame-stx ()) (begin #'(define-values () (values)))] - [(_ marker blame-stx ((p0 c0) (p c) ...) (u ...)) + [(_ blame-stx (i0 i ...)) (raise-syntax-error 'with-contract "no definition found for identifier" - #'p0)] - [(_ marker blame-stx () (u0 u ...)) - (raise-syntax-error 'with-contract - "no definition found for identifier" - #'u0)] - [(_ marker blame-stx ((p c) ...) (u ...) body0 body ...) + #'i0)] + [(_ blame-stx (i ...) body0 body ...) (let ([expanded-body0 (local-expand #'body0 (syntax-local-context) - (cons #'splicing-syntax-parameterize - (kernel-form-identifier-list)))]) + (kernel-form-identifier-list))]) (syntax-case expanded-body0 (begin define-values) [(begin sub ...) (syntax/loc stx - (with-contract-helper marker blame-stx ((p c) ...) (u ...) sub ... body ...))] + (with-contract-helper blame-stx (i ...) sub ... body ...))] [(define-values (id ...) expr) - (let*-values ([(marker-f) (syntax-e #'marker)] - [(used-p/cs used-us unused-p/cs unused-us) - (partition-ids (syntax->list #'(id ...)) - (map syntax->list (syntax->list #'((p c) ...))) - (syntax->list #'(u ...)))]) - (with-syntax ([(u-def ...) - (map (λ (u) - #`(define-syntaxes (#,u) - (make-rename-transformer (quote-syntax #,(marker-f u))))) - used-us)] - [(p/c-def ...) - (apply append - (map (λ (p/c) - (let* ([p (car p/c)] - [c (cadr p/c)] - [contract-id - (if (a:known-good-contract? c) - #f - (marker-f (a:mangle-id stx "with-contract-contract-id" p)))] - [always-defined - (list #`(define-syntaxes (#,p) - (make-with-contract-transformer - (quote-syntax #,(if contract-id contract-id c)) - (quote-syntax #,(marker-f p)) - (quote-syntax blame-stx))) - #`(define-values () - (begin - (-contract #,(if contract-id contract-id c) - #,(marker-f p) - blame-stx - 'cant-happen - #,(id->contract-src-info p)) - (values))))]) - (if contract-id - (cons #`(define-values (#,contract-id) - (verify-contract 'with-contract #,(marker-f c))) - always-defined) - always-defined))) - used-p/cs))]) - (quasisyntax/loc stx - (begin #,(marker-f expanded-body0) - u-def ... p/c-def ... - (with-contract-helper marker blame-stx #,unused-p/cs #,unused-us - body ...)))))] - [(splicing-syntax-parameterize bindings . ssp-body) - (let* ([marker-f (syntax-e #'marker)] - [expanded-ssp (local-expand (quasisyntax/loc expanded-body0 - (splicing-syntax-parameterize bindings . - #,(marker-f #'ssp-body))) - (syntax-local-context) - (kernel-form-identifier-list))]) - (quasisyntax/loc stx - (begin #,expanded-ssp - (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))] + (with-syntax ([def expanded-body0] + [unused-is (let ([ids (syntax->list #'(id ...))]) + (filter (λ (i1) + (not (ormap (λ (i2) + (bound-identifier=? i1 i2)) + ids))) + (syntax->list #'(i ...))))]) + (with-syntax () + (syntax/loc stx + (begin def (with-contract-helper blame-stx unused-is body ...)))))] [else - (let*-values ([(marker-f) (syntax-e #'marker)]) - (quasisyntax/loc stx - (begin #,(marker-f expanded-body0) - (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))]))])) + (quasisyntax/loc stx + (begin #,expanded-body0 + (with-contract-helper blame-stx (i ...) body ...)))]))])) (define-for-syntax (check-and-split-with-contracts single-allowed? args) (let loop ([args args] @@ -378,13 +295,10 @@ improve method arity mismatch contract violation error messages? (raise-syntax-error 'with-contract "use of #:freevar with non-identifier" #'x)] - [(_ #:type type blame (arg ...) #:freevars (fv ...) body0 . body) + [(_ #:type type blame (arg ...) #:freevars (fv ...) . body) (and (identifier? #'blame) (identifier? #'type)) - (let*-values ([(marker) (let ([marker (make-syntax-introducer)]) - (λ (x) - (syntax-local-introduce - (marker (syntax-local-introduce x)))))] + (let*-values ([(marker) (make-syntax-introducer)] [(no-need free-vars free-ctcs) (check-and-split-with-contracts #f (syntax->list #'(fv ...)))] [(unprotected protected protections) @@ -402,17 +316,19 @@ improve method arity mismatch contract violation error messages? [(free-ctc-id ...) (map (λ (i) (marker (a:mangle-id stx "with-contract-contract-id" i))) free-vars)] - [(free-ctc ...) (map (lambda (c) - (if (a:known-good-contract? c) - c - #`(coerce-contract 'with-contract #,c))) - free-ctcs)] - [((p c) ...) (map list protected protections)] - [(u ...) unprotected]) + [(free-ctc ...) free-ctcs] + [(ctc-id ...) (map (λ (i) + (marker (a:mangle-id stx "with-contract-contract-id" i))) + protected)] + [(ctc ...) protections] + [(p ...) protected] + [(marked-p ...) (map marker protected)] + [(src-info ...) (map id->contract-src-info protected)] + [(u ...) (map marker unprotected)]) (quasisyntax/loc stx (begin (define-values (free-ctc-id ...) - (values free-ctc ...)) + (values (verify-contract 'with-contract free-ctc) ...)) (define blame-id (current-contract-region)) (define-syntaxes (free-var-id ...) @@ -422,17 +338,27 @@ improve method arity mismatch contract violation error messages? (quote-syntax blame-id) (quote-syntax blame-stx)) ...)) (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) - (with-contract-helper #,marker blame-stx ((p c) ...) (u ...) body0 . body)))))))] + (with-contract-helper blame-stx (marked-p ... u ...) . #,(marker #'body))) + (define-values (ctc-id ...) + (values (verify-contract 'with-contract ctc) ...)) + (define-values () + (begin (-contract ctc-id + marked-p + blame-stx + 'cant-happen + src-info) ... + (values))) + (define-syntaxes (p ...) + (values (make-with-contract-transformer + (quote-syntax ctc) + (quote-syntax marked-p) + (quote-syntax blame-stx)) ...)))))))] [(_ #:type type blame (arg ...) #:freevar x c . body) (syntax/loc stx (with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))] - [(_ #:type type blame (arg ...) body0 . body) + [(_ #:type type blame (arg ...) . body) (syntax/loc stx - (with-contract #:type type blame (arg ...) #:freevars () body0 . body))] - [(_ #:type type blame (arg ...)) - (raise-syntax-error 'with-contract - "empty body" - stx)] + (with-contract #:type type blame (arg ...) #:freevars () . body))] [(_ #:type type blame bad-args etc ...) (raise-syntax-error 'with-contract "expected list of identifier and/or (identifier contract)" From cf916f51fa5e199f2d4b9b2d6e405f69e429048d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 19:58:26 +0000 Subject: [PATCH 020/142] Forgot to add rename-transformers for unprotected ids. svn: r13704 --- collects/scheme/private/contract.ss | 10 ++++++---- collects/tests/mzscheme/contract-test.ss | 8 ++++++++ 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index b1027087c0..53e005458f 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -324,7 +324,8 @@ improve method arity mismatch contract violation error messages? [(p ...) protected] [(marked-p ...) (map marker protected)] [(src-info ...) (map id->contract-src-info protected)] - [(u ...) (map marker unprotected)]) + [(u ...) unprotected] + [(marked-u ...) (map marker unprotected)]) (quasisyntax/loc stx (begin (define-values (free-ctc-id ...) @@ -338,7 +339,7 @@ improve method arity mismatch contract violation error messages? (quote-syntax blame-id) (quote-syntax blame-stx)) ...)) (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) - (with-contract-helper blame-stx (marked-p ... u ...) . #,(marker #'body))) + (with-contract-helper blame-stx (marked-p ... marked-u ...) . #,(marker #'body))) (define-values (ctc-id ...) (values (verify-contract 'with-contract ctc) ...)) (define-values () @@ -348,8 +349,9 @@ improve method arity mismatch contract violation error messages? 'cant-happen src-info) ... (values))) - (define-syntaxes (p ...) - (values (make-with-contract-transformer + (define-syntaxes (u ... p ...) + (values (make-rename-transformer #'marked-u) ... + (make-with-contract-transformer (quote-syntax ctc) (quote-syntax marked-p) (quote-syntax blame-stx)) ...)))))))] diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 2e4c85d6f9..c8b3733f63 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2523,6 +2523,14 @@ (define (x n) (if (y n) 4 0))) (x 4)) "(region region2)") + + ;; make sure uncontracted exports make it out + (test/spec-passed + 'with-contract9 + '(let () + (with-contract region1 (f) + (define f 3)) + f)) ; ; From d18a56a95610cf599cc8bb0a4a6db8e4280a8c4a Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 20:32:04 +0000 Subject: [PATCH 021/142] Okay, no infinite syntax unrolling, please. svn: r13705 --- collects/scheme/private/contract.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 53e005458f..d0a26df997 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -95,7 +95,7 @@ improve method arity mismatch contract violation error messages? #'args)] [(_ name+arg-list contract #:freevars (arg ...) #:freevar x c . body) (syntax/loc define-stx - (define/contract name+arg-list contract #:freevars (arg ... [x c]) #:freevar x c . body))] + (define/contract name+arg-list contract #:freevars (arg ... [x c]) . body))] [(_ name+arg-list contract #:freevar x c . body) (syntax/loc define-stx (define/contract name+arg-list contract #:freevars () #:freevar x c . body))] From 9098c94e9c07a7f0d9d7e5f1213efa70da5f5176 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 20:48:04 +0000 Subject: [PATCH 022/142] Add first-order checks for free variable contracts, and tests for everything. svn: r13706 --- collects/tests/mzscheme/contract-test.ss | 64 ++++++++++++++++++++++++ 1 file changed, 64 insertions(+) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index c8b3733f63..889578f278 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2401,6 +2401,70 @@ (eval '(require 'foo-dc18))) "(unit U@)") + (test/spec-failed + 'define/contract19 + '(let () + (define y 3) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + 3) + 1) + "top-level") + + (test/spec-passed + 'define/contract20 + '(let () + (define y (lambda (n) 4)) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + 3) + 1)) + + (test/spec-passed + 'define/contract21 + '(let () + (define y (lambda (n) 4)) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + (if (y n) 3 1)) + 1)) + + (test/spec-failed + 'define/contract22 + '(let () + (define y 4) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + 3) + 1) + "top-level") + + (test/spec-failed + 'define/contract23 + '(let () + (define y (lambda (n) #t)) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? number?) + (y n)) + (f 5)) + "top-level") + + (test/spec-failed + 'define/contract24 + '(let () + (define y (lambda (n) 4)) + (define/contract (f n) + (-> number? number?) + #:freevar y (-> number? boolean?) + (if (y #t) 3 1)) + (f 5)) + "(function f)") + ; ; From 3ff2184a38223fbc0b986e0b9f771eec2e16e59c Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 20:50:56 +0000 Subject: [PATCH 023/142] Add the first-order free variable contract checks I mentioned earlier. svn: r13707 --- collects/scheme/private/contract.ss | 6 ++++++ collects/tests/mzscheme/contract-test.ss | 12 ++++++++++++ 2 files changed, 18 insertions(+) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index d0a26df997..f3e2731138 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -317,6 +317,7 @@ improve method arity mismatch contract violation error messages? (marker (a:mangle-id stx "with-contract-contract-id" i))) free-vars)] [(free-ctc ...) free-ctcs] + [(free-src-info ...) (map id->contract-src-info free-vars)] [(ctc-id ...) (map (λ (i) (marker (a:mangle-id stx "with-contract-contract-id" i))) protected)] @@ -348,6 +349,11 @@ improve method arity mismatch contract violation error messages? blame-stx 'cant-happen src-info) ... + (-contract free-ctc-id + free-var + blame-id + 'cant-happen + free-src-info) ... (values))) (define-syntaxes (u ... p ...) (values (make-rename-transformer #'marked-u) ... diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 889578f278..b009255492 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2465,6 +2465,18 @@ (f 5)) "(function f)") + (test/spec-failed + 'define/contract25 + '(let () + (define y #t) + (define z 3) + (define/contract f + number? + #:freevars ([y number?] [z number?]) + (+ y z)) + 1) + "top-level") + ; ; From 42a5b158318698e9bce60b5f4a36e3065bf23801 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Feb 2009 21:01:55 +0000 Subject: [PATCH 024/142] switching machines to be able to make an image svn: r13708 --- .../games/chat-noir/chat-noir-literate.ss | 271 +++++++++++------- 1 file changed, 172 insertions(+), 99 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index cdf27fcc15..39223a036b 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -9,6 +9,10 @@ scribble ++xref-in setup/xref load-collections-xref --htmls chat-noir-doc.ss @title{Chat Noir} +@author[(link "http://www.eecs.northwestern.edu/~robby" "Robby Findler") + (link "http://www.barzilay.org/" "Eli Barzilay") + (link "http://www.cs.utah.edu/~mflatt/" "Matthew Flatt")] + The goal of Chat Noir is to stop the cat from escaping the board. Each turn you click on a circle, which prevents the cat from stepping on that space, and the cat responds by taking a step. If the cat is @@ -28,7 +32,8 @@ project for the introductory programming course at the University of Chicago in the fall of 2008. The remainder of this document explains the implementation of -the Chat Noir game. +the Chat Noir game in a +@link["http://www.literateprogramming.com/"]{Literate Programming} style. @section{Overview} @@ -56,10 +61,10 @@ Each section also comes with a series of test cases that are collected into the @chunk[ - + graph-tests> - - ] + + ] Each test case uses either @scheme[test], a simple form that accepts two arguments and compares them with @scheme[equal?], or @scheme[test/set] @@ -259,18 +264,12 @@ blocked, in which case it has no edges at all (even to the boundary). This section describes the implementation of the breadth-first search, leaving details of how the graph connectivity is computed from the board to the next section. -The code for the breadth-first search is organized into -X parts .... - @chunk[ - - - - ] + + ] @chunk[ - ] @@ -285,6 +284,22 @@ and the @tt{n} field is a natural number or @scheme['∞], indicating the distance of the shortest path from the node to some fixed point on the board. +The function @scheme[lookup-in-table] returns the distance from the fixed +point to the given posn, returning @scheme['∞] if the posn is not in the +table or if it is mapped to @scheme['∞] in the table. + +@chunk[ + (define/contract (lookup-in-table t p) + (-> (listof dist-cell?) posn? + (or/c '∞ natural-number/c)) + (cond + [(empty? t) '∞] + [else (cond + [(equal? p (dist-cell-p (first t))) + (dist-cell-n (first t))] + [else + (lookup-in-table (rest t) p)])]))] + The @scheme[build-bfs-table] accepts a world and a cell (indicating the fixed point) and returns a distance map encoding the distance to that cell. @@ -351,7 +366,9 @@ is in @scheme[dist-table]. If it is, we just move on to the next element in the queue. If that node is not in the @scheme[dist-table], then we add all of the neighbors to the queue, in the @scheme[append] expression, and update the @scheme[dist-table] with the distance to -this node. +this node. Because we always add the new children to the end of the queue +and always look at the front of the queue, we are guaranteed that +the first time we see a node, it will be with the shortest distance. The @scheme[build-bfs-table] function packages up @scheme[bfs] function. It accepts a @scheme[world] and an initial position @@ -377,12 +394,28 @@ it calls the @scheme[bfs] function and then transforms the result, using @scheme[hash-map], into a list of @scheme[cell]s. +@section{Board to Graph Functions} + As far as the @scheme[build-bfs-table] function goes, all of the information specific to Chat Noir is encoded in the neighbors function. It accepts a world and returns a function that computes the neighbors of the boundary -and of nodes. +and of nodes. This section describes how +it is implemented. + +@chunk[graph> + + + + + ] + +@chunk[graph-tests> + + + + ] The neighbors functions accepts a @scheme[world] and then returns a function that computes the neighbors of a @scheme[posn] @@ -408,7 +441,7 @@ and @scheme[(make-posn 0 1)] has four neighbors: (make-posn 0 2) (make-posn 1 2)))] -as you can see from the pictures of the 7x7 empty board above. +as you can see in the earlier pictures of the 7x7 empty board. Also, there are 6 neighbors of the boundary in the 3x3 board: @chunk[ @@ -420,7 +453,6 @@ Also, there are 6 neighbors of the boundary in the 3x3 board: (make-posn 2 1) (make-posn 2 2)))] - This is the neighbors function. After it accepts the @scheme[world], it builds a list of the blocked cells in the world and a list of the cells that are on the boundary (and not blocked). Then it @@ -461,8 +493,14 @@ we know that @scheme[p] must have been on the boundary, so we add @scheme['boundary] to the result list. @chunk[ -(define/contract (neighbors-blocked/boundary blocked boundary-cells size p) - (-> (listof posn?) (listof posn?) natural-number/c (or/c 'boundary posn?) +(define/contract (neighbors-blocked/boundary blocked + boundary-cells + size + p) + (-> (listof posn?) + (listof posn?) + natural-number/c + (or/c 'boundary posn?) (listof (or/c 'boundary posn?))) (cond @@ -485,20 +523,8 @@ we know that @scheme[p] must have been on the boundary, so we add (cons 'boundary in-bounds)]))]))] -@section{Board to Graph Functions} - -There are three functions that build the basic graph structure -from a board. - -@chunk[graph> - - - ] - -@chunk[graph-tests> - - - ] +There are the three functions that build the basic graph structure +from a board as used by @scheme[neighbors]. The first function is @scheme[adjacent]. It consumes a @scheme[posn] and returns six @scheme[posn]s that @@ -506,7 +532,9 @@ indicate what the neighbors are, without consideration of the size of the board (or the missing corner pieces). For example, these are the @scheme[posn]s that are adjacent -to @scheme[(make-posn 0 1)]. +to @scheme[(make-posn 0 1)]; note that the first and the third +are not on the board and do not show up in +@scheme[neighbors] function example above. @chunk[ (test (adjacent (make-posn 0 1)) @@ -574,33 +602,11 @@ of the two corners that have been removed. (not (equal? p (make-posn 0 0))) (not (equal? p (make-posn 0 (- board-size 1))))))] - - -@chunk[ -;; lookup-in-table : distance-map posn -> number or '∞ -;; looks for the distance as recorded in the table t, -;; if not found returns a distance of '∞ -(define (lookup-in-table t p) - (cond - [(empty? t) '∞] - [else (cond - [(equal? p (dist-cell-p (first t))) - (dist-cell-n (first t))] - [else - (lookup-in-table (rest t) p)])]))] - -@chunk[ - -(test (lookup-in-table empty (make-posn 1 2)) '∞) -(test (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3)) - (make-posn 1 2)) - 3) -(test (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3)) - (make-posn 1 2)) - '∞)] - @section{The Cat's Path} +Once we have a breadth-first search all sorted out, we can use it to build a function that +determines where the shortest paths from the cat's current position to the boundary are. + @chunk[ <+/f>] @@ -609,11 +615,58 @@ of the two corners that have been removed. <+/f-tests>] +The function @scheme[on-cats-path?] accepts a world and returns a predicate +on the @scheme[posn]s in the world. The predicate indicates if the given +@scheme[posn] is on the shortest path. + +For example, in a world of size @scheme[7] with the cat at +@scheme[(make-posn 2 2)], the circles with white centers +are on the shortest path to the boundary: + +@schemeblock[(render-world + (make-world (empty-board 7) + (make-posn 2 2) + 'playing + 7 + false + true))] + +So we can formulate two test cases using this world, one +in the white circles and one not: + +@chunk[ + (test ((on-cats-path? (make-world (empty-board 7) + (make-posn 2 2) + 'playing + 7 + false + true)) + (make-posn 1 0)) + true) + (test ((on-cats-path? (make-world (empty-board 7) + (make-posn 2 2) + 'playing + 5 + false + true)) + (make-posn 4 4)) + false)] + +The computation of the shortest path to the boundary proceeds by computing +two distance maps; the distance map to the boundary and the distance map +to the cat. Then, a node is on one of the shortest paths if the distance +to the cat plus the distance to the boundary is equal to the distance from +the cat to the boundary. + +The code is essentially that, plus two other special cases. Specifically if the +``h'' key is not pressed down, then we just consider no cells to be on that shortest +path. And if the distance to the cat is @scheme['∞], then again no nodes are on the +path. The second situation happens when the cat is completely boxed in and has +lost the game. + @chunk[ -;; on-cats-path? : world -> posn -> boolean -;; returns true when the posn is on the shortest path -;; from the cat to the edge of the board, in the given world - (define (on-cats-path? w) + (define/contract (on-cats-path? w) + (-> world? (-> posn? boolean?)) (cond [(world-h-down? w) (let () @@ -632,35 +685,8 @@ of the two corners that have been removed. [else (lambda (p) false)]))] -@chunk[ - (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) true)) - (make-posn 1 0)) - true) - (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) false)) - (make-posn 1 0)) - false) - (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) true)) - (make-posn 2 1)) - false) - (test ((on-cats-path? - (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 0 0) - true)) - (make-posn 0 1)) - false)] +Finally, the helper function @scheme[+/f] is just like @scheme[+], except that +it returns @scheme['∞] if either argument is @scheme['∞]. @chunk[<+/f> (define (+/f x y) @@ -670,14 +696,6 @@ of the two corners that have been removed. [else (+ x y)]))] -@chunk[<+/f-tests> - (test (+/f '∞ '∞) '∞) - (test (+/f '∞ 1) '∞) - (test (+/f 1 '∞) '∞) - (test (+/f 1 2) 3)] - - - @section{Tests} @chunk[ @@ -734,6 +752,15 @@ of the two corners that have been removed. (printf "passed ~s tests\n" test-count) (flush-output))] +@chunk[ + (test (lookup-in-table empty (make-posn 1 2)) '∞) + (test (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3)) + (make-posn 1 2)) + 3) + (test (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3)) + (make-posn 1 2)) + '∞)] + @chunk[ (test/set (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) @@ -981,6 +1008,52 @@ of the two corners that have been removed. (test (in-bounds? (make-posn 10 0) 11) true) (test (in-bounds? (make-posn 0 10) 11) false)] +@chunk[ + (test ((on-cats-path? (make-world (empty-board 5) + (make-posn 1 1) + 'playing + 5 + (make-posn 0 0) + true)) + (make-posn 1 0)) + true) + (test ((on-cats-path? (make-world (empty-board 5) + (make-posn 1 1) + 'playing + 5 + (make-posn 0 0) + false)) + (make-posn 1 0)) + false) + + (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) true)) + (make-posn 2 1)) + false) + (test ((on-cats-path? + (make-world (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn 0 0) + true)) + (make-posn 0 1)) + false)] + + +@chunk[<+/f-tests> + (test (+/f '∞ '∞) '∞) + (test (+/f '∞ 1) '∞) + (test (+/f 1 '∞) '∞) + (test (+/f 1 2) 3)] + @section{Everything Else} From b5bc25915aa214a761ba6265eee56016218bdcac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Feb 2009 21:32:26 +0000 Subject: [PATCH 025/142] fix image scaling in Scribble HTML output svn: r13709 --- collects/scribble/html-render.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index d140e03e62..e472fa42d1 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -1011,8 +1011,8 @@ (if (path? p) (url->string (path->url (path->complete-path p))) p))] - . ,(attribs)) - ,@sz)))] + ,@(attribs) + ,@sz))))] [else (render*)]))) (define/override (render-table t part ri need-inline?) From bd208ad5206175814d62a892877d3759824046ad Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Feb 2009 21:50:10 +0000 Subject: [PATCH 026/142] checkpointing: got thru the first five sections as a first draft; broke out the next two sections svn: r13710 --- .../games/chat-noir/cat-distance-example.png | Bin 0 -> 13329 bytes .../games/chat-noir/chat-noir-literate.ss | 978 +++++++++--------- 2 files changed, 484 insertions(+), 494 deletions(-) create mode 100644 collects/games/chat-noir/cat-distance-example.png diff --git a/collects/games/chat-noir/cat-distance-example.png b/collects/games/chat-noir/cat-distance-example.png new file mode 100644 index 0000000000000000000000000000000000000000..a4c90eb07d627e3e1a1126cd8086fc978d32d1cb GIT binary patch literal 13329 zcmb_?1yohr{`El+kUA(JU6LXt4IUa)KqLfdq@)|^?mU2igwlc{AR%4Sq0&fqgLL=d zTZen^d-uNoyYK(LZ+woyaO}O$UVH7e*P6e%=A5C5Paol8kzqj~5L}tZQpykr%0uvn zi+K&4IcL$rgg~w_nn_A3%1BDmDB9Z?n_0euKwMBh$M#tK6eDb}AC=Zpx!tFXcJt0- zRrQyvRHeETeB;#P@w}GLhNwSU#!R+Yf1&+WQ0B62vz<;1m5@f;dJa3dtV57K8fW%&RFu04ey?vY-9zHu0^3&A%kLM_CqK4zO1_4m=MWXIhE$_Eo0&AD%t*f)rMqeofiPdfvZcJHi^t zG@I2--ryT-SNjYjs2kOtdj5F$A;p&P`w~&qcQp_BR~R&9rQ9&iExH_*`h3~G`?9X~ zO(zXAC=vM_$frLwOl_M#YZ#%MIc5`ML(#mEWT1qjE6MpFOCWXe*RHmp2BJP{d{a5? z)`N%Bbh_`|;Kpq)E*=k}1=nSpHOiZOxHIze2e#j^Wj0GCY3EP0>7ixS#`ua_`VkwZ zEw9V`PbxNn1D}k$hH`AqMZ_!0SzWSAqJPQfB~Nu(s1XOYg|e((WHk6b5kwSqXv(|gzdEn+9r!}$8iSC!$DszBH_)ZxAY|MocahJH z*)}+J0Tbtj?PCoG2n3q|`G*2|n@j?M&_HCQ#8q5SHaxM5CL2bvBkj8+7o z8?zY}_vH-p3r(+_d_Pk6&;a^5_7wc&vr1%muY?qfi`LNiYmTjIm6+Fu5Pa;Yl_|LrJ`zjxG8pVuV2h3*ZBBph;B~@iZ>1Z?MBJn9f|;k zh z4X+!XL?E*5FO8&kN^`PyBG8U1Bx9@%P%$Ay(%TdPq{wy&;e(lnvzd`o74s(!9eXV2 zH-!+}M~a90@(p2NwFv zeuhDxQV$+U5aZ~5Am8I+%+z-?`#R}>|5U=IqeQJR`&(5`aN?1<1Kx?HoR;iE?@!)@ zsGZ#H=T;90u?|X4CJW=g-89Zt#T9rvu_=fNr-k9q;tskkXVNlPRd8d-aw%F#%gkS} zoO$AC+h7cpcvzA&x28jEA%p0t{zXdP{TbQ9wCA;@8VAM4lKi_lwXMO=J!R+&vqGkO zg2ac}D@W4cVlvr@si-$^sWI%zz{6Du!3nnAuyLyEKdBDw2-qWnj?%Et4kxDhyhMow zo38V>g}e1VP0xyYZOSBY5Wl*>oX(rau=%m+l)lY(x#wYF z-^&NLm_HE?;Yqh?mQmh_Q=!E8LKzlOW{x~9^i&AkCLf$fN5K4Pj4OrWdMObD+Zry> zeTF@mFgLi<|J{>6Gq1j)a5XYXpC&OyzJS<#gGY~BFtX3LGXMEdJfjDMq!xot^oq)k z$*;J4W8UJaJz`W;E_*2?h?S%9WYs>6f^^ND3}eZLyzXHF@^)qQf8IjT@u!hkHM+*Y zOIZ;4Bt6Ug$18in-sf>VLu=)3a{7wpvA98w-nRb2~-nJ&tTUQ~hlwyx2sOWog}~2#Ky_d97fs zou6q6KF@2li9_b}&&+1)QN9QJaMUfisWXGX+@Ru%FoqdO?oD9~{r7Pg@|uKIZB-$D zdH$u`7%BRd6QFr7ewXplr*0d2hQ6w}+$7_DkVo&<0e+}sLis9G-PcmWbD7IMA2<{_ zu>WGan{}sRWn*OP!z*!J!e8=hPUQ7@eb@c_-O%x8cBvcxX2pzs$-Qw{*yP0zb<#=_ z^G4TxDq7|092*#hk1M8A@ne@F;FlQHzUwD8ei(6?U76uKhhA6o?^busvcfO&sNAzX zPVQ?fi+(jb-;pQs(zIYN%Et3~6&?@Xi7pyLUI$n3dsU8ap3YdBe>a~LJH-TTx1CiH zHRWMp7&$jJE`D2^bE-e*609^h_?)C%OH-x)G2vOC{w2$UdB!?S-Ri}ZWg46ZNTlvh zR8SXvv)d6-jJ*5%&yZ^X5Fd;6h^yNpQNN>-=v_K36;(kM0~NczX!VLJ+xWzFYu#1B zbxH~^_Cx%>pdEZ&jjyCuv})>-gzqF;$9miOTZl4Kf*E0ic+Us>`eWj8irHdqNTDpr z7}U^QW4V^+2|V`gOHW2Rub8RRBjw(=*SQv-I+K7zt!c;I4rOc1`=k`0Zejs&D zDM`A7__C$?<1fO_+xDW%vo3}caA=krUGdS~8YG)y4$n&M5y=?K;=>NVcA~SgECu^Bo<2DLgcq$xyu*&_G&VSq0X}_EY%JycSse{SYPcZ3&jFt$ zIr!@$t)|SpAnuZ(N%ot^pp1n1x#KlO?Dh7*q_lD{xr<*wb4<@~n0>J)p@F=zZk%IE z^~YHhqY6WCp_e}rB=%L8HU{(Ky=%y`{=}^?{(E6AJ!4V77nsdNd1oqt{!n0yan0^cjW_umNRd>T3QptBqD{{vDfZAm0o?PY{Is#ZQIE? z=-^~Pla7tfIRJMh6-(58YjZ>q5Q|T>yFO@PX3zeMcBu}AF-t$6k>$0Ev!u0s8)eC6 zdE5~jSy{y8t~ceE=AvLIQcgSI^GUe$*77ERCAm~71gf+pCiJE(*_PVq7HrP#K~X9L zH%YT}8g~r%`Q(ZqCV4i@v_G?hw_BP}o3aJm9uSPl06${jt*1wY)TezaRtXGGA@z-s z-4VvPLth}f5KBg!$4urMqq#s-ks@|gWpLA-W(ftKnzx_z#O{B?+O#3BPh%S29GJP* z?&(wVGpj} z{qUbh+t3?lUBi&V<;Ct4@jVsZhz&JXF#F(tJNquIx64aD2yhg7da)Me>Z8wlpiN#A z7&B^j!1n^P`w8D)W;a82PAIq0y7RMY8V;<34~{kP>A@90aWi35OxqJ9hPfYT zzD*8y3vuP>5f}L8LQ*{!c5jzQ)hbDdCnU)o3!apDMi+L=$e>SgkJ+3AA2Dqc?A+4w0sAWF#%RiBp21Mr^B5} z@RVfg|51)|0GEekX_c;n73T{x{bk;v)Gdvxy)g%l-v&4B_O=9ej3jxgHnMorZu;{1 zaF+W30C>2Zk>(omyr0HyHMx7Y>OQJ+3Y`E=&TEw(aZG@A@xd`z8Gd(F)z~)mE_0Pj z$j~vvXJ{hogGRHyJ@dImOn11-jNXMazKIdx@J@R@#geH#22Sww_k zr}{8@Rx`!WuB4(Q>_e1>>e)AVF#Z>O75>5Z+b%X5e6EVZ{tajb1Dtod_#sa`VXMb2 zR*j%ghA(*7x>arW-nwLC7y9UZ7g!=0P?6sbVbdwPjy8nbo*&bXx~Fo#(5khzJO3tP z5sa97xBs5rPbF6wn@Pb)TniQ=`X&1A2+inJ|Ep@k8KzO4A9ErSb#ltOKjwn2ld`40vdp~A zEbiK!;gW{;xg0{q%tqB6h%VZDW?90pgPBhQA1)DTI*t=&Cgb#Dbq{nW%acREj8|JAW1@nvaT{61n)e0QG$up>Tu*+5TZiLN;R z(x_6Xoa5{3OrgU?WLdu)&0*$|-`%^d_mSIVwvRl`)!rlD=w@~VdS$1O|>KfdnDyMew(Qx{pQnywKR|2 zZ)q3nCQ#Ay?Iq&04KjTAago(h2JUi`12Y-S>1-;dt+Xrp+lY$|wmYw(yUP0YyW@rW z?!@aaeHZ78pF6D{5noXV*&9|J8TT}ro10CN?b>ox^PU%I3mUdX6!29lL>e~wU1xT= zKT>WrKIuH|*-q(vzQ82v#W51WMyUdhL&ZsUY6er&n+xU<)+e`$t_!UDPq z_&DnJ`&HF+95>2_H^<7hu+Fieo0d(IYU#Of+#YGw%7VjG|6b)5Nwxm=vuD=1* zhzO)$G0}!(M}UII9Kn|R^w~D*F?ZTY=UZM2p3uw6<;s(#cWQ;Y7oQY7u|!Ksrtr_8-p9=) z#$BgP#9wVE!MX^hc9_PNLufEiapkK^z#VR43x&@ELgz}w6~=OdvX;Y4V1|pVJ`LBu zK*zSYupW?$u+b6Ugi28 zV&a9Q6k1_Wc-ksEZvS;l`g`eqgt9TRwmOd}-#ODTdH=GqL8&4d@RAt2e2O7N6o>9X zJ2C9od04LvlLm9YpiETL`7&y$J0*O&E~WvOe}bl|*xPlT)`XG^W!Wbj$htuf-N(-(to!0YShh`7wi{GJ&u12y;4RzJdXT3&L`r z>^FX;f5ortDX5a%`nT$izFayDcpoDMayH!Sz2`Hf!>4v4owYp=q^vIM&%Ccqmvjr= z3%Bi)CJsGcsCTy?7?ZE5Sa0*jPnUH!7Bdg2gWO>5Ev#C4>-=>uC801m$7mr4=W>Q) zIA7q>vqSI))8F)}`O6f3V7E$=Ld>UGzbj=S49UPW7eYP_=WN9Gcy9$y9Sfzh={Qe1 zR$7!6^uH zf$&}@H%HY%Of1LcP{+Q8kTKK<&_ODC21SqsF7jqR-3TV(wkZf_ruDk)O3H zsO(p?JEui1&-WCB4}LoI2&*xM%|;$wC)Q4#_E^ z!moO#SZRXg?69I9K0c#Ze~dph`yie4VBts6qaQqo3(^@6DU z>=>K+i^DX;{>P8W_E?r)=kwG(TIUa|YS`^8sW9)wYp!ayT+0>!q(K6PFXwBH@i)3l z@3hb&&hZpL%;QYNceSs(&D4nP+P&_Yz3vA+B4?J`O5R{yH}hBFA&R3saq`GkZ+B98 z4%bX&Ytg)qnLX=^@*=deuG!#wLU`E-_1Z2g^t7_;sg6R-KKro^(;M@`_X z?~&N60V7fZTJN(EPi}PtLhZe9$E;{U&H;ge{ZgjzZU-HHs_PQz1bwr`o9G=P+>_X} z^DL5N+ol_LcrK6jE*lb#x(t6|zUdBhiePrflVIFYjGEQY|0udGk-_o()|T3=XM{w! zHKpzSU!+t7>AzOw@l?nYC`C(cPrq)BELTKbw5CLPZV217)v_nyv)t&n(VGx#rqu~2 z=4d10WrXWjDO?c2b0GUV^d0QKrO*#ZGoveUC zkiuboC&6RWrl9KlNXed~{+w$_uw&CWBSQ4@q-Xg>eA^;Fd(rS`tzZ+Sy``=nB7~c< zvt;BLh&vrx1NQZ}&aGS3YwWBp*Jv747iq((<#O!U4a80CU>F&9dL$nzG3d|1nJv`~ z&t|$<2y?CI>NrbYH2aax>|3atnknGfz#JFNh`sS|c!Gi`r9VGZI?*Lzx3s3gb@@xJ zK5S7+blVq-iMr2GJA+LQ`{Z^wYNFJ`slKiC!^v{mZ9mS6*CqY<4@pgzl(Yic@dCj`WucGj@6n`z{hSM|PWNq_A&F}f_50Zz`sgdq6oef+{P=4x3$2@ZdeSa! zyRtvlqBsmI{&Leb$Al8rmya!I|3n8;qd4Z>Io}m5r6YDGmox77NLkKDBK`I|R+Ru# zrmi(YHkF@e6pC_{mTl|BmWZKJqWYtj$k6PNq7TcI-WRLxg*CVK6l}}RfeE#k?9hGx zHp`vN^zRJ()^FxdxTk7bS`W<3 zwn^RPG_}*u9SOo6AEqe{D?{Uz8ur@b?D;7^0jtd20m?X3l$+3>F)Lm0ObRZRU6_$hF;KM< zSr;>I&7R4US=W!s70*x3%STNfJ@U4dIZV-RQMn1_jbG}K46s!48AGgBSR-Co6uj8~ z@J#LNCBX>|u9k#7MCv9Kx36{5A*V%BU^!NHjQ`2aIiw_)ph({4-`yV1H0jaSoINNP zROJ0;<5`(nd6ncgKKS}T%}frCcKbH|>fZZvPs&5M^P(G$n>P;Aqqp4Gx?i#=w& z!XlTKe)GVd?bn8_;|@CD+k-AOG80U`d{a82Z$WMu=U`E(TTZkmRPyjx zmV9l?u+Ey*B5aYS*pe(>Bj&(#dyHR~pw;5#qbKAorH)VBKbXZ}ZVDb(b+jc$VaQAC zvU8a2m?=kVIY$}}B+Ggea&mCh+r%%=EK5Y`QA6LtpWv~rc4oxPB!o*O?9ISdnq-8i zZpD{QcSe`20MWBL^;s0y32#JEED#DoyZzahrXqrm8Q_iiI*mG^Wkd^$AVc+Gke|8i)!Z zkVA}~G;mjyUIp~OwXj})bqj~BWI1kQLNAs>6rM4Z*ICP~a_eLzzMt>$T; z${02=e()pz_~LhejCRbQ%H6t4%jQnXVxj|{k5JJ2|aSKVEUZZMwq!J7c|-wVT}n9XWm zysXa(T-#`HyX~ZhLo96l7@b1QaUSKh|5Jf5ZU12AN}&)SZUVXfO0GN*WF&}#eVe9Fy+uOX0|fygXC!V}heyH|2&m|5^0!_Q-&E4h)ePk{qBF#D?m9F#x#YiE$c zYcZny^&G*wwjGfm{oXQccH8wa1~_;J!E#y**}L(w)X9JPMsn#{Z4$-v_{^WmZSr-& zD46Acw4o2!G6j>1_{AdNS<0RN-N(MTU-T`=ZpQPQ`-^7`J61dMR_;kKf3*y#c(*I~_FooM2# za^JRP{;Dy(G!+G{(t``!aniX~#xt8iWia&vxM!NJ&Amiw+OI`b!6(AQHDJ_Sg&n{j zpi@n7md_sS^zHb5l0Fj+8E$IHcO1 z_m9wsw0sH0rHK&E6ULYwa$PZ@%6!A~SX=00iHCKkkIFeF9;P`xfO-j}8=q&_doX)36Fc0SYR<4j_yfnVIbeQH8!dO=L-megeY~C3Z{RA9o3< zcVHN4IZYXfzB^?9f`kjHmS$qH-@pvFz2Pdx@AK5 z6^Z)LC@&J|4LLFu0|!P+bN@QbA}7~u)Sk_Ru8o`1%bho3Tg_8ql#`nvH&%|mAxKXmBju2b{0^tdVy9MVGz%rmvx~mF93=y#&6af zbquy#HMKQ8KCzDKvbd=o(o-Dveaq`~*UWpJc3lA4E%}@Ye~gprm54M~!hS*V4zEH~ z!MO4co}<#S@CKKX5!R-`@1;lps!zoI&Afm8{yAlsZjV^=m5V0RaXoCArUluOcxW7t z0*l#`ld!XkWM4W~Ka*Tq0P~T^Zof2mwQgc@Mc>pAqVM*}`sS#EE!BPwl4<17J8$DbmTc5^ z%}j9we16dYp&RK;Rfpb>J$i_;5m)eWn!feU3$WSlxM%$Ul#Tykdi@@)004qC<8LE3i8x`9 z{<6Qv&wmL>0AZv5%wJ4qLtX@c-EuEEI$B@{QyG5}z^gNcV7GKi4V#=)2P+QH38xWR z0FUO`ie+$6g~s&n34#}RBQeMa(9$CK^8&~wJjYTU7rJ!pEc z4*KnOKhF((2G#e2C18iW)|&rI8uT0fyhjAf6k~05*xzOjoZt(k*aXNO)NW=V^B;~# z!H5G$Zj|PLHlV1`x#2Yhfl0Jdox@}(*&%MJ{;a1em3YQ9mJ)F2SAfd8@n+XChLN64 zqH%QOd9HOpu4zvV05k=}llBGW8%@Ss>@zj}cOA0UWpI?ZY4#ru9mo3)v?>D7(dZnO z_0L9@XJK8*&!~MMiZ{XX=|nCcC3ryT78|GKd_>o%B*ohiNYe<%m;=6b3dVAV%$tp~ zZY27_78m&ek?RJ~=Y?ds1%&UNmEoT?CmIo|L5>^jz`w?K{xjcZ;f85z))_Ioss7+| z#!Lhd#|RSpz>C}q6U&g331=#Q34#>z z|l^PpixPAkg2WV34K{_U$xz&h9jh}*l$giFTywJ@rW@OExpi)@v~mT80y6E$1i?E}``chR|B)c*3;*{Cg2Z<&9Y$~NHWvE0 z;c>+z2a7D|1K7JD&Q6WEV&O?MP&8ytapI>_G2ABm(wqRxf7cME-lmY(fy*y(8vFhD2 zAg2CI{FLesG86mUP&-*Nf_+XR*uBqL*L*lB*`Tw6m`vT0X?yq|v+m!h{gp>~@)pMu zz+l1>98}E~*A)k88u8zTo- z4=CK4ebVtyvJM#uz+x`64*}kDTGkN;SpV-l0HyB9;K#wl0s$i%E?Pxp_ju69_=6y~ zSi2zbxPR(b$zn2HoiSJd2$WY?1%RrS#6SdG?W|r6TO>7QO~&r_;VzmcMK%vD`cKW< zx16TdiGq8l766HN!>iL5Qw;G?c8|RQx>P~|hHhwWL%y0U@HgW7=TO$ad-Xqz@KSzo z^_Sp&5Q;eME&yak(A5`jAeSN_PYK} z7=7gbXA;IU>W6w%VJDiuf8_AI&9%{C+acqTv}iIF>M=UiUOr9SN+&%ic-Bg?57j!;U}s0mK=@Y+Z-nO5274%i&O8# zi?_JhsgKJH`8C!ox$qMezL~usf1=e6GkMD%#)IUIO$|0w&{GHTO=%fyqkjuR*93ao z{SmB56E!j2H1}?JRWZL31dC2@wzN9yY}WW;hpRmmNW;<^m6n!fT>unIby?Yrh0Ln32@Yzd%be66W41hPB>wq`dEj&Vvx6Vf72n z0ze>#jPqiWRu~La152@_a=M3<7#R3T=9sDe(eogQhGAH#tX3mSb|h*bPnX?um*r0+ z4BXm*ZW7X)8Pn!K_JjskrW$Z>APRtZ9S{Y;rh?~r_?VVTf1=Qsk%UVhQmV}Rdymxx7`_)3x+qA#Q=0w5(B8S14Km6g*PQ|?bh(>)lB?C*JQ z1fhAt(RBohY$!5mw)?)cG@A&ZUU_1@&RYv9R8WC2uBJOk^{(uYvR7ng?Rcqn$Z5`| z<^H?{cKIMY1-Ke`C1H`~MG%ghO2Fw6hzCUC@AlWf@7<)38Pxd;le709R)8h+jAqFY zFdx@5LN>5Ov06NyfF*8|mI>Coyl-L@-~^yo2ROUb9FEukXUKHseg{RY4QN~4H?VX66KcjXr=Pt~wBOhB z?3tnl9k$s8Few~7#Yw{qvQTy3=&?-i$&#%d9R3#oeHDrY!O(#|6+(c`$XM_1-1GM! zD4H)8LS>HAef&?;*`{dp2qN31KS z5u%UOV`-^=2uY5*k$&!^!MR5fa1R*(UwC9=CKr{P!viJJ`&U#0aeHaQvYa|wTVla1 zi}tGxrjAD_&Tq)}Th?+g%v4E+?jYMi=*Kf%FA$Bfj0Aa~c4SolFeG~_W=DQVSn;=X z451h@8}k~(LBAm{)6PG)^b2xvsa%S8sVsH-rnsLQZ?%aJqnGT_-M@jo-8ba1ZRKiZwXFA6`e}zJ(=xuQmA3X*|@7vbvf8`g(DYM zHJ*x@rMrw={7C~OFE?O47uR#Ku6*)4*DZ(kM+28sQ zUtNI8g3{1Rh4n*d*|5=P#{BEP&h0w|ccd0GGf literal 0 HcmV?d00001 diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 39223a036b..441b71e983 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -3,7 +3,7 @@ @;{ The command to build this: -scribble ++xref-in setup/xref load-collections-xref --htmls chat-noir-doc.ss +mzc chat-noir-doc.ss && scribble ++xref-in setup/xref load-collections-xref --htmls chat-noir-doc.ss } @@ -53,6 +53,8 @@ and some code that builds an initial world and starts the game. graph> + + ] @@ -64,7 +66,8 @@ Each section also comes with a series of test cases that are collected into the graph-tests> - ] + + ] Each test case uses either @scheme[test], a simple form that accepts two arguments and compares them with @scheme[equal?], or @scheme[test/set] @@ -341,6 +344,8 @@ and that @scheme[posn]'s distance. (-> (listof (vector/c (or/c 'boundary posn?) natural-number/c)) hash? hash?) + #:freevar neighbors/w (-> (or/c 'boundary posn?) + (listof (or/c 'boundary posn?))) (cond [(empty? queue) dist-table] [else @@ -623,34 +628,23 @@ For example, in a world of size @scheme[7] with the cat at @scheme[(make-posn 2 2)], the circles with white centers are on the shortest path to the boundary: -@schemeblock[(render-world - (make-world (empty-board 7) - (make-posn 2 2) - 'playing - 7 - false - true))] +@image["cat-distance-example.png"] So we can formulate two test cases using this world, one in the white circles and one not: @chunk[ - (test ((on-cats-path? (make-world (empty-board 7) + (let ([on-the-path? + (on-cats-path? (make-world (empty-board 7) (make-posn 2 2) 'playing 7 false - true)) - (make-posn 1 0)) - true) - (test ((on-cats-path? (make-world (empty-board 7) - (make-posn 2 2) - 'playing - 5 - false - true)) - (make-posn 4 4)) - false)] + true))]) + (test (on-the-path? (make-posn 1 0)) + true) + (test (on-the-path? (make-posn 4 4)) + false))] The computation of the shortest path to the boundary proceeds by computing two distance maps; the distance map to the boundary and the distance map @@ -696,6 +690,475 @@ it returns @scheme['∞] if either argument is @scheme['∞]. [else (+ x y)]))] +@section{Drawing the Cat} + +@chunk[ + ;; cat : symbol -> image + (define (cat mode) + (local [(define face-color + (cond + [(symbol=? mode 'sad) 'pink] + [else 'lightgray])) + + (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3))) + (define right-ear (regular-polygon 3 8 'solid 'black 0)) + (define ear-x-offset 14) + (define ear-y-offset 9) + + (define eye (overlay (ellipse 12 8 'solid 'black) + (ellipse 6 4 'solid 'limegreen))) + (define eye-x-offset 8) + (define eye-y-offset 3) + + (define nose (regular-polygon 3 5 'solid 'black (/ pi 2))) + + (define mouth-happy + (overlay (ellipse 8 8 'solid face-color) + (ellipse 8 8 'outline 'black) + (move-pinhole + (rectangle 10 5 'solid face-color) + 0 + 4))) + (define mouth-no-expression + (overlay (ellipse 8 8 'solid face-color) + (ellipse 8 8 'outline face-color) + (rectangle 10 5 'solid face-color))) + + (define mouth + (cond + [(symbol=? mode 'happy) mouth-happy] + [else mouth-no-expression])) + (define mouth-x-offset 4) + (define mouth-y-offset -5)] + + (add-line + (add-line + (add-line + (add-line + (add-line + (add-line + (overlay (move-pinhole left-ear (- ear-x-offset) ear-y-offset) + (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) + (ellipse 40 26 'solid 'black) + (ellipse 36 22 'solid face-color) + (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) + (move-pinhole mouth mouth-x-offset mouth-y-offset) + (move-pinhole eye (- eye-x-offset) eye-y-offset) + (move-pinhole eye eye-x-offset eye-y-offset) + (move-pinhole nose -1 -4)) + 6 4 30 12 'black) + 6 4 30 4 'black) + 6 4 30 -4 'black) + -6 4 -30 12 'black) + -6 4 -30 4 'black) + -6 4 -30 -4 'black))) + + (define happy-cat (cat 'happy)) + (define sad-cat (cat 'sad)) + (define thinking-cat (cat 'thinking))] + + +@section{Drawing a World} + +@chunk[ + (define circle-radius 20) + (define circle-spacing 22) + + (define normal-color 'lightskyblue) + (define on-shortest-path-color 'white) + (define blocked-color 'black) + (define under-mouse-color 'black) + + + image> + image> + + + + ] + +@chunk[ + + + + image-tests> + image-tests> + + ] + +@chunk[ +;; render-world : world -> image +(define (render-world w) + (chop-whiskers + (overlay (board->image (world-board w) + (world-size w) + (on-cats-path? w) + (world-mouse-posn w)) + (move-pinhole + (cond + [(equal? (world-state w) 'cat-won) happy-cat] + [(equal? (world-state w) 'cat-lost) sad-cat] + [else thinking-cat]) + (- (cell-center-x (world-cat w))) + (- (cell-center-y (world-cat w)))))))] + +@chunk[ + + (test + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'playing + 2 + (make-posn 0 0) + false)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2 + (lambda (x) true) + false) + (move-pinhole thinking-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + + (test + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-won + 2 + false + false)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2 + (lambda (x) true) + false) + (move-pinhole happy-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + + (test + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-lost + 2 + false + false)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2 + (lambda (x) true) + false) + (move-pinhole sad-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + + (test + (render-world + (make-world (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3 + false + false)) + (overlay + (board->image (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + 3 + (lambda (x) false) + false) + (move-pinhole sad-cat + (- (cell-center-x (make-posn 1 1))) + (- (cell-center-y (make-posn 1 1)))))) + + (test + (render-world + (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn (cell-center-x (make-posn 0 1)) + (cell-center-y (make-posn 0 1))) + true)) + + (overlay + (board->image (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + 3 + (lambda (x) true) + (make-posn (cell-center-x (make-posn 0 1)) + (cell-center-y (make-posn 0 1)))) + (move-pinhole sad-cat + (- (cell-center-x (make-posn 1 1))) + (- (cell-center-y (make-posn 1 1))))))] + +@chunk[ +;; chop-whiskers : image -> image +;; crops the image so that anything above or to the left of the pinhole is gone +(define (chop-whiskers img) + (shrink img + 0 + 0 + (- (image-width img) (pinhole-x img) 1) + (- (image-height img) (pinhole-y img) 1)))] + +@chunk[ + (test (chop-whiskers (rectangle 5 5 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) + (test (chop-whiskers (rectangle 6 6 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) + + (test + (pinhole-x + (render-world + (make-world + (empty-board 3) + (make-posn 0 0) + 'playing + 3 + (make-posn 0 0) + false))) + 0) + (test + (pinhole-x + (render-world + (make-world + (empty-board 3) + (make-posn 0 1) + 'playing + 3 + (make-posn 0 0) + false))) + 0)] + +@chunk[image> +;; board->image : board number (posn -> boolean) posn-or-false -> image + (define (board->image cs world-size on-cat-path? mouse) + (foldl (lambda (x y) (overlay y x)) + (nw:rectangle (world-width world-size) + (world-height world-size) + 'solid + 'white) + (map (lambda (c) + (cell->image c + (on-cat-path? (cell-p c)) + (and (posn? mouse) + (equal? mouse (cell-p c))) + #; + (and (posn? mouse) + (point-in-this-circle? (cell-p c) + (posn-x mouse) + (posn-y mouse))))) + cs)))] + +@chunk[image-tests> + (test (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) false) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false + false))) + + (test (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) true) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + true + false))) + + + (test (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) false) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false + false))) + + (test (board->image (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) (equal? x (make-posn 0 1))) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false + false) + (cell->image (make-cell (make-posn 0 1) false) + true + false))) + + (test (board->image (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) (equal? x (make-posn 0 1))) + (make-posn 0 0)) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false + true) + (cell->image (make-cell (make-posn 0 1) false) + true + false)))] + +@chunk[image> + ;; cell->image : cell boolean boolean -> image + (define (cell->image c on-short-path? under-mouse?) + (local [(define x (cell-center-x (cell-p c))) + (define y (cell-center-y (cell-p c))) + (define main-circle + (cond + [(cell-blocked? c) + (circle circle-radius 'solid blocked-color)] + [else + (circle circle-radius 'solid normal-color)]))] + (move-pinhole + (cond + [under-mouse? + (overlay main-circle + (circle (quotient circle-radius 2) 'solid under-mouse-color))] + [on-short-path? + (overlay main-circle + (circle (quotient circle-radius 2) 'solid + on-shortest-path-color))] + [else + main-circle]) + (- x) + (- y))))] + +@chunk[image-tests> + (test (cell->image (make-cell (make-posn 0 0) false) false false) + (move-pinhole (circle circle-radius 'solid normal-color) + (- circle-radius) + (- circle-radius))) + (test (cell->image (make-cell (make-posn 0 0) true) false false) + (move-pinhole (circle circle-radius 'solid 'black) + (- circle-radius) + (- circle-radius))) + (test (cell->image (make-cell (make-posn 0 0) false) true false) + (move-pinhole (overlay (circle circle-radius 'solid normal-color) + (circle (quotient circle-radius 2) 'solid + on-shortest-path-color)) + (- circle-radius) + (- circle-radius))) + (test (cell->image (make-cell (make-posn 0 0) false) true true) + (move-pinhole (overlay (circle circle-radius 'solid normal-color) + (circle (quotient circle-radius 2) 'solid + under-mouse-color)) + (- circle-radius) + (- circle-radius)))] + +@chunk[ + + ;; world-width : number -> number + ;; computes the width of the drawn world in terms of its size + (define (world-width board-size) + (local [(define rightmost-posn + (make-posn (- board-size 1) (- board-size 2)))] + (+ (cell-center-x rightmost-posn) circle-radius)))] + +@chunk[ + ;; world-height : number -> number + ;; computes the height of the drawn world in terms of its size + (define (world-height board-size) + (local [(define bottommost-posn + (make-posn (- board-size 1) (- board-size 1)))] + (+ (cell-center-y bottommost-posn) circle-radius)))] + +@chunk[ + (test (world-width 3) 150) + (test (world-height 3) 116.208)] + +@chunk[ + ;; cell-center-x : posn -> number + (define (cell-center-x p) + (local [(define x (posn-x p)) + (define y (posn-y p))] + (+ circle-radius + (* x circle-spacing 2) + (if (odd? y) + circle-spacing + 0))))] + +@chunk[ + (test (cell-center-x (make-posn 0 0)) + circle-radius) + (test (cell-center-x (make-posn 0 1)) + (+ circle-spacing circle-radius)) + (test (cell-center-x (make-posn 1 0)) + (+ (* 2 circle-spacing) circle-radius)) + (test (cell-center-x (make-posn 1 1)) + (+ (* 3 circle-spacing) circle-radius))] + +@chunk[ + ;; cell-center-y : posn -> number + (define (cell-center-y p) + (local [(define y (posn-y p))] + (+ circle-radius + (* y circle-spacing 2 + .866 ;; .866 is an exact approximate to sin(pi/3) + ))))] + +@chunk[ + (test (cell-center-y (make-posn 1 1)) + (+ circle-radius (* 2 circle-spacing .866))) + (test (cell-center-y (make-posn 1 0)) + circle-radius)] + + @section{Tests} @chunk[ @@ -1062,393 +1525,6 @@ it returns @scheme['∞] if either argument is @scheme['∞]. #;'() -;; constants -(define circle-radius 20) -(define circle-spacing 22) - -(define normal-color 'lightskyblue) -(define on-shortest-path-color 'white) -(define blocked-color 'black) -(define under-mouse-color 'black) - - -; -; -; -; -; ;; ;;;; -; ;;;; ;;;;; -; ;;; ; -; ;;; ;;; ; ;;;; ;;;; ;;;;;; ;; ;;;; ;;;;;; ;; ;;;; ;;; -; ;;;;;;;;;;;;;; ;;;; ;;;;;;;;; ;; ;; ; ;;;;; ;;; ;;;; ;;;;;;; -; ;;;;;;;;; ;;; ;;;;;;;;;;;;;;; ;;; ;; ;; ;;; ;;; ;;;; ; ;;;; -; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;; ;;; -; ;; ;;;; ;;; ;; ;;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;;;; -; ;;;;;;;; ;;; ;;;;;;;;;; ;;; ;; ;;;;; ;;;; ;;; ;;; ;;; -; ;;;;;;;;;;;;;;;; ;;;;;;;;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; ;;;; ;;; -; ;;;;; ;;;; ;;;; ;;;;; ;;; -; ;;;;;;; ;;; -; ;;;;;; -; - - -;; render-world : world -> image -(define (render-world w) - (chop-whiskers - (overlay (board->image (world-board w) - (world-size w) - (on-cats-path? w) - (world-mouse-posn w)) - (move-pinhole - (cond - [(equal? (world-state w) 'cat-won) happy-cat] - [(equal? (world-state w) 'cat-lost) sad-cat] - [else thinking-cat]) - (- (cell-center-x (world-cat w))) - (- (cell-center-y (world-cat w))))))) - -(test - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'playing - 2 - (make-posn 0 0) - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true) - false) - (move-pinhole thinking-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -(test - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'cat-won - 2 - false - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true) - false) - (move-pinhole happy-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -(test - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'cat-lost - 2 - false - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true) - false) - (move-pinhole sad-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -(test - (render-world - (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - false - false)) - (overlay - (board->image (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - 3 - (lambda (x) false) - false) - (move-pinhole sad-cat - (- (cell-center-x (make-posn 1 1))) - (- (cell-center-y (make-posn 1 1)))))) - -(test - (render-world - (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn (cell-center-x (make-posn 0 1)) - (cell-center-y (make-posn 0 1))) - true)) - - (overlay - (board->image (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - 3 - (lambda (x) true) - (make-posn (cell-center-x (make-posn 0 1)) - (cell-center-y (make-posn 0 1)))) - (move-pinhole sad-cat - (- (cell-center-x (make-posn 1 1))) - (- (cell-center-y (make-posn 1 1)))))) - -;; chop-whiskers : image -> image -;; crops the image so that anything above or to the left of the pinhole is gone -(define (chop-whiskers img) - (shrink img - 0 - 0 - (- (image-width img) (pinhole-x img) 1) - (- (image-height img) (pinhole-y img) 1))) - -(test (chop-whiskers (rectangle 5 5 'solid 'black)) - (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) -(test (chop-whiskers (rectangle 6 6 'solid 'black)) - (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) - -(test - (pinhole-x - (render-world - (make-world - (empty-board 3) - (make-posn 0 0) - 'playing - 3 - (make-posn 0 0) - false))) - 0) -(test - (pinhole-x - (render-world - (make-world - (empty-board 3) - (make-posn 0 1) - 'playing - 3 - (make-posn 0 0) - false))) - 0) - - -;; board->image : board number (posn -> boolean) posn-or-false -> image -(define (board->image cs world-size on-cat-path? mouse) - (foldl (lambda (x y) (overlay y x)) - (nw:rectangle (world-width world-size) - (world-height world-size) - 'solid - 'white) - (map (lambda (c) - (cell->image c - (on-cat-path? (cell-p c)) - (and (posn? mouse) - (equal? mouse (cell-p c))) - #; - (and (posn? mouse) - (point-in-this-circle? (cell-p c) - (posn-x mouse) - (posn-y mouse))))) - cs))) - -(test (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) false) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false))) - -(test (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) true) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - true - false))) - - -(test (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) false) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false))) - -(test (board->image (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) (equal? x (make-posn 0 1))) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false) - (cell->image (make-cell (make-posn 0 1) false) - true - false))) - -(test (board->image (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) (equal? x (make-posn 0 1))) - (make-posn 0 0)) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - true) - (cell->image (make-cell (make-posn 0 1) false) - true - false))) - -;; cell->image : cell boolean boolean -> image -(define (cell->image c on-short-path? under-mouse?) - (local [(define x (cell-center-x (cell-p c))) - (define y (cell-center-y (cell-p c))) - (define main-circle - (cond - [(cell-blocked? c) - (circle circle-radius 'solid blocked-color)] - [else - (circle circle-radius 'solid normal-color)]))] - (move-pinhole - (cond - [under-mouse? - (overlay main-circle - (circle (quotient circle-radius 2) 'solid under-mouse-color))] - [on-short-path? - (overlay main-circle - (circle (quotient circle-radius 2) 'solid - on-shortest-path-color))] - [else - main-circle]) - (- x) - (- y)))) - -(test (cell->image (make-cell (make-posn 0 0) false) false false) - (move-pinhole (circle circle-radius 'solid normal-color) - (- circle-radius) - (- circle-radius))) -(test (cell->image (make-cell (make-posn 0 0) true) false false) - (move-pinhole (circle circle-radius 'solid 'black) - (- circle-radius) - (- circle-radius))) -(test (cell->image (make-cell (make-posn 0 0) false) true false) - (move-pinhole (overlay (circle circle-radius 'solid normal-color) - (circle (quotient circle-radius 2) 'solid - on-shortest-path-color)) - (- circle-radius) - (- circle-radius))) -(test (cell->image (make-cell (make-posn 0 0) false) true true) - (move-pinhole (overlay (circle circle-radius 'solid normal-color) - (circle (quotient circle-radius 2) 'solid - under-mouse-color)) - (- circle-radius) - (- circle-radius))) - -;; world-width : number -> number -;; computes the width of the drawn world in terms of its size -(define (world-width board-size) - (local [(define rightmost-posn - (make-posn (- board-size 1) (- board-size 2)))] - (+ (cell-center-x rightmost-posn) circle-radius))) - -(test (world-width 3) 150) - -;; world-height : number -> number -;; computes the height of the drawn world in terms of its size -(define (world-height board-size) - (local [(define bottommost-posn - (make-posn (- board-size 1) (- board-size 1)))] - (+ (cell-center-y bottommost-posn) circle-radius))) -(test (world-height 3) 116.208) - - -;; cell-center-x : posn -> number -(define (cell-center-x p) - (local [(define x (posn-x p)) - (define y (posn-y p))] - (+ circle-radius - (* x circle-spacing 2) - (if (odd? y) - circle-spacing - 0)))) - -(test (cell-center-x (make-posn 0 0)) - circle-radius) -(test (cell-center-x (make-posn 0 1)) - (+ circle-spacing circle-radius)) -(test (cell-center-x (make-posn 1 0)) - (+ (* 2 circle-spacing) circle-radius)) -(test (cell-center-x (make-posn 1 1)) - (+ (* 3 circle-spacing) circle-radius)) - -;; cell-center-y : posn -> number -(define (cell-center-y p) - (local [(define y (posn-y p))] - (+ circle-radius - (* y circle-spacing 2 - .866 ;; .866 is an exact approximate to sin(pi/3) - )))) - -(test (cell-center-y (make-posn 1 1)) - (+ circle-radius (* 2 circle-spacing .866))) -(test (cell-center-y (make-posn 1 0)) - circle-radius) - ; ; @@ -1944,92 +2020,6 @@ it returns @scheme['∞] if either argument is @scheme['∞]. -; -; -; -; -; -; ;;;; -; ;;; -; ;;; ; -; ;;;;;; ;;;; ;;;;;;;;;;; -; ;;; ;;;; ;;;;;;;;; ;;; ;; -; ;;; ;;;;;;;;;;;;;;; ;;; -; ;;; ;;;;;;; ;;; ;;; ;;;; -; ;;; ;; ;;;; ;;; ;;;;; -; ;;; ; ;;;;;;;;;; ;;; ;;;; -; ;;; ; ;;;;;;;;;;; ;;; ;; -; ;;;; ;;;;; ;;;;; -; -; -; - - -;; cat : symbol -> image -(define (cat mode) - (local [(define face-color - (cond - [(symbol=? mode 'sad) 'pink] - [else 'lightgray])) - - (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3))) - (define right-ear (regular-polygon 3 8 'solid 'black 0)) - (define ear-x-offset 14) - (define ear-y-offset 9) - - (define eye (overlay (ellipse 12 8 'solid 'black) - (ellipse 6 4 'solid 'limegreen))) - (define eye-x-offset 8) - (define eye-y-offset 3) - - (define nose (regular-polygon 3 5 'solid 'black (/ pi 2))) - - (define mouth-happy - (overlay (ellipse 8 8 'solid face-color) - (ellipse 8 8 'outline 'black) - (move-pinhole - (rectangle 10 5 'solid face-color) - 0 - 4))) - (define mouth-no-expression - (overlay (ellipse 8 8 'solid face-color) - (ellipse 8 8 'outline face-color) - (rectangle 10 5 'solid face-color))) - - (define mouth - (cond - [(symbol=? mode 'happy) mouth-happy] - [else mouth-no-expression])) - (define mouth-x-offset 4) - (define mouth-y-offset -5)] - - (add-line - (add-line - (add-line - (add-line - (add-line - (add-line - (overlay (move-pinhole left-ear (- ear-x-offset) ear-y-offset) - (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) - (ellipse 40 26 'solid 'black) - (ellipse 36 22 'solid face-color) - (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) - (move-pinhole mouth mouth-x-offset mouth-y-offset) - (move-pinhole eye (- eye-x-offset) eye-y-offset) - (move-pinhole eye eye-x-offset eye-y-offset) - (move-pinhole nose -1 -4)) - 6 4 30 12 'black) - 6 4 30 4 'black) - 6 4 30 -4 'black) - -6 4 -30 12 'black) - -6 4 -30 4 'black) - -6 4 -30 -4 'black))) - -(define happy-cat (cat 'happy)) -(define sad-cat (cat 'sad)) -(define thinking-cat (cat 'thinking)) - - ; ; ; From acef860a60126cbdc8637dbe425dad6ce8261993 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 17 Feb 2009 22:11:14 +0000 Subject: [PATCH 027/142] Unit contracts svn: r13711 --- .../htdocs/lang-servlets/add-param.ss | 1 + .../htdocs/lang-servlets/add-simple.ss | 1 + .../htdocs/lang-servlets/add.ss | 2 ++ collects/web-server/http/request.ss | 9 ++++--- collects/web-server/lang.ss | 14 +++++------ collects/web-server/lang/util.ss | 20 ++++++++++++--- .../web-server/private/dispatch-server-sig.ss | 25 ++++++++++++++----- collects/web-server/scribblings/private.scrbl | 20 +++++++-------- collects/web-server/scribblings/running.scrbl | 10 ++++---- .../scribblings/web-config-unit.scrbl | 10 ++++---- collects/web-server/web-config-sig.ss | 23 +++++++++++------ collects/web-server/web-config-unit.ss | 4 +-- collects/web-server/web-server.ss | 8 +++--- 13 files changed, 93 insertions(+), 54 deletions(-) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss index 6099ad5021..632e16f282 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss @@ -3,6 +3,7 @@ (provide start interface-version) (define msg (make-parameter "unknown")) +(define printf void) (define (gn) (printf "gn ~a~n" (msg)) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss index 8bcc653a5d..f416ee5866 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss @@ -3,6 +3,7 @@ (provide start interface-version) (define msg (make-web-parameter "unknown")) +(define printf void) (define (gn) (printf "gn ~a~n" (msg)) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss index eae0530e17..b6b1352909 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss @@ -2,6 +2,8 @@ (define interface-version 'stateless) (provide start interface-version) +(define printf void) + ;; get-number-from-user: string -> number ;; ask the user for a number (define (get-number msg) diff --git a/collects/web-server/http/request.ss b/collects/web-server/http/request.ss index 8917ec1757..6a89746f4e 100644 --- a/collects/web-server/http/request.ss +++ b/collects/web-server/http/request.ss @@ -1,6 +1,5 @@ #lang scheme -(require mzlib/contract - mzlib/plt-match +(require mzlib/plt-match net/url mzlib/list net/uri-codec @@ -10,7 +9,11 @@ (provide/contract [rename ext:read-request read-request - ((connection? number? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))]) + (connection? + port-number? + (input-port? . -> . (values string? string?)) + . -> . + (values request? boolean?))]) (define (ext:read-request conn host-port port-addresses) (with-handlers ([exn? (lambda (exn) diff --git a/collects/web-server/lang.ss b/collects/web-server/lang.ss index 6fd66ca732..1ba70de28f 100644 --- a/collects/web-server/lang.ss +++ b/collects/web-server/lang.ss @@ -13,15 +13,15 @@ (provide (rename-out [lang-module-begin #%module-begin]) (all-from-out "lang/lang-api.ss")) +(define-for-syntax anormalize (make-anormal-term elim-letrec-term)) + (define-syntax lang-module-begin (make-lang-module-begin make-labeling (make-module-case/new-defs (make-define-case/new-defs - (compose #;(lambda (stx) (values stx empty)) - defun - elim-callcc - (make-anormal-term elim-letrec-term) - #;(make-anormal-term (lambda (x) x)) - #;elim-letrec-term - ))))) + (lambda (stx) + (define anf-stx (anormalize stx)) + (define no-callcc-stx (elim-callcc anf-stx)) + (define-values (defun-stx new-defs) (defun no-callcc-stx)) + (values defun-stx new-defs)))))) diff --git a/collects/web-server/lang/util.ss b/collects/web-server/lang/util.ss index 1894034ce7..af3afa7803 100644 --- a/collects/web-server/lang/util.ss +++ b/collects/web-server/lang/util.ss @@ -1,9 +1,21 @@ #lang scheme/base (require (for-template scheme/base) - syntax/kerncase - mzlib/pretty - mzlib/list) -(provide (all-defined-out)) + scheme/pretty + scheme/list + scheme/contract + syntax/kerncase) +(provide/contract + [transformer? (parameter/c boolean?)] + [recertify (syntax? syntax? . -> . syntax?)] + [recertify* (syntax? (listof syntax?) . -> . (listof syntax?))] + [recertify/new-defs (syntax? (-> (values syntax? (listof syntax?))) . -> . (values syntax? (listof syntax?)))] + [current-code-labeling (parameter/c (syntax? . -> . syntax?))] + [generate-formal ((symbol?) ((or/c false/c syntax?)) . ->* . (values syntax? syntax?))] + [formals-list (syntax? . -> . (listof syntax?))] + [make-define-case/new-defs ((syntax? . -> . (values syntax? (listof syntax?))) . -> . (syntax? . -> . (listof syntax?)))] + [make-module-case/new-defs ((syntax? . -> . (listof syntax?)) . -> . (syntax? . -> . (listof syntax?)))] + [make-lang-module-begin ((bytes? . -> . (-> symbol?)) (syntax? . -> . (listof syntax?)) . -> . (syntax? . -> . syntax?))] + [bound-identifier-member? (syntax? (listof syntax?) . -> . boolean?)]) (define transformer? (make-parameter #f)) diff --git a/collects/web-server/private/dispatch-server-sig.ss b/collects/web-server/private/dispatch-server-sig.ss index d2487f49bd..67346d6e3f 100644 --- a/collects/web-server/private/dispatch-server-sig.ss +++ b/collects/web-server/private/dispatch-server-sig.ss @@ -1,13 +1,26 @@ -#lang scheme/base -(require mzlib/unit) +#lang scheme +(require web-server/private/util + web-server/private/connection-manager) (define-signature dispatch-server^ - (serve - serve-ports)) + ((contracted + [serve (-> (-> void))] + [serve-ports (input-port? output-port? . -> . (-> void))]))) (define-signature dispatch-server-config^ - (port listen-ip max-waiting initial-connection-timeout - read-request dispatch)) + ((contracted + [port port-number?] + [listen-ip (or/c string? false/c)] + [max-waiting integer?] + [initial-connection-timeout integer?] + [read-request + (connection? + port-number? + (input-port? . -> . (values string? string?)) + . -> . + (values any/c boolean?))] + [dispatch + (-> connection? any/c void)]))) (provide dispatch-server^ dispatch-server-config^) diff --git a/collects/web-server/scribblings/private.scrbl b/collects/web-server/scribblings/private.scrbl index 44f3ec298a..6df3c4b026 100644 --- a/collects/web-server/scribblings/private.scrbl +++ b/collects/web-server/scribblings/private.scrbl @@ -147,21 +147,19 @@ The @scheme[dispatch-server^] signature is an alias for @defsignature[dispatch-server-config^ ()]{ - @defthing[port port?]{Specifies the port to serve on.} - @defthing[listen-ip string?]{Passed to @scheme[tcp-accept].} + @defthing[port port-number?]{Specifies the port to serve on.} + @defthing[listen-ip (or/c string? false/c)]{Passed to @scheme[tcp-listen].} @defthing[max-waiting integer?]{Passed to @scheme[tcp-accept].} @defthing[initial-connection-timeout integer?]{Specifies the initial timeout given to a connection.} @defproc[(read-request [c connection?] - [p port?] - [port-addresses (-> port? boolean? - (or/c (values string? string?) - (values string? (integer-in 1 65535) - string? (integer-in 1 65535))))]) - any/c]{ + [p port-number?] + [port-addresses + (input-port? . -> . (values string? string?))]) + (values any/c boolean?)]{ Defines the way the server reads requests off connections to be passed to @scheme[dispatch]. } - @defthing[dispatch dispatcher/c]{How to handle requests.} + @defthing[dispatch (-> connection? any/c void)]{How to handle requests.} } } @@ -173,8 +171,8 @@ The @scheme[dispatch-server^] signature is an alias for The @schememodname[web-server/private/dispatch-server-unit] module provides the unit that actually implements a dispatching server. -@defthing[dispatch-server@ (unit/c (tcp^ dispatch-server-config^) - (dispatch-server^))]{ +@defthing[dispatch-server@ (unit/c (import tcp^ dispatch-server-config^) + (export dispatch-server^))]{ Runs the dispatching server config in a very basic way, except that it uses @secref["connection-manager.ss"] to manage connections. } diff --git a/collects/web-server/scribblings/running.scrbl b/collects/web-server/scribblings/running.scrbl index b749364283..a1de7b68e0 100644 --- a/collects/web-server/scribblings/running.scrbl +++ b/collects/web-server/scribblings/running.scrbl @@ -99,7 +99,7 @@ of the @web-server in other applications, or loading a custom dispatcher. @defproc[(serve [#:dispatch dispatch dispatcher/c] - [#:tcp@ tcp@ tcp-unit^ raw:tcp@] + [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@] [#:port port integer? 80] [#:listen-ip listen-ip (or/c string? false/c) #f] [#:max-waiting max-waiting integer? 40] @@ -127,7 +127,7 @@ from a given path: ] @defproc[(serve/ports [#:dispatch dispatch dispatcher/c] - [#:tcp@ tcp@ tcp-unit^ raw:tcp@] + [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@] [#:ports ports (listof integer?) (list 80)] [#:listen-ip listen-ip (or/c string? false/c) #f] [#:max-waiting max-waiting integer? 40] @@ -138,7 +138,7 @@ from a given path: } @defproc[(serve/ips+ports [#:dispatch dispatch dispatcher/c] - [#:tcp@ tcp@ tcp-unit^ raw:tcp@] + [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@] [#:ips+ports ips+ports (listof (cons/c (or/c string? false/c) (listof integer?))) (list (cons #f (list 80)))] [#:max-waiting max-waiting integer? 40] [#:initial-connection-timeout initial-connection-timeout integer? 60]) @@ -147,8 +147,8 @@ from a given path: a function that shuts down all of the server instances. } -@defproc[(serve/web-config@ [config@ web-config^] - [#:tcp@ tcp@ tcp-unit^ raw:tcp@]) +@defproc[(serve/web-config@ [config@ (unit/c (import) (export web-config^))] + [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]) (-> void)]{ Starts the @web-server with the settings defined by the given @scheme[web-config^] unit. diff --git a/collects/web-server/scribblings/web-config-unit.scrbl b/collects/web-server/scribblings/web-config-unit.scrbl index 76d050c98d..ea6ac8d626 100644 --- a/collects/web-server/scribblings/web-config-unit.scrbl +++ b/collects/web-server/scribblings/web-config-unit.scrbl @@ -31,7 +31,7 @@ Provides contains the following identifiers. Passed to @scheme[tcp-accept]. } -@defthing[virtual-hosts (listof (cons/c string? host-table?))]{ +@defthing[virtual-hosts (string? . -> . host?)]{ Contains the configuration of individual virtual hosts. } @@ -43,8 +43,8 @@ Provides contains the following identifiers. Specifies the port to serve HTTP on. } -@defthing[listen-ip string?]{ - Passed to @scheme[tcp-accept]. +@defthing[listen-ip (or/c false/c string?)]{ + Passed to @scheme[tcp-listen]. } @defthing[make-servlet-namespace make-servlet-namespace/c]{ @@ -62,7 +62,7 @@ Provides contains the following identifiers. [#:port port (or/c false/c port-number?) #f] [#:listen-ip listen-ip (or/c false/c string?) #f] [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)]) - (unit? web-config^)]{ + (unit/c (import) (export web-config^))]{ Reads the S-expression at @scheme[path] and calls @scheme[configuration-table-sexpr->web-config@] appropriately. } @@ -74,7 +74,7 @@ Provides contains the following identifiers. [#:listen-ip listen-ip (or/c false/c string?) #f] [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)]) - (unit? web-config^)]{ + (unit/c (import) (export web-config^))]{ Parses @scheme[sexpr] as a configuration-table and constructs a @scheme[web-config^] unit. } diff --git a/collects/web-server/web-config-sig.ss b/collects/web-server/web-config-sig.ss index 6ba8ea286f..497cd1e3a3 100644 --- a/collects/web-server/web-config-sig.ss +++ b/collects/web-server/web-config-sig.ss @@ -1,8 +1,17 @@ -#lang scheme/signature +#lang scheme +(require web-server/private/util + web-server/configuration/namespace + web-server/configuration/configuration-table-structs) -max-waiting -virtual-hosts -initial-connection-timeout -port -listen-ip -make-servlet-namespace +(provide + web-config^) + +(define-signature + web-config^ + ((contracted + [max-waiting integer?] + [virtual-hosts (string? . -> . host?)] + [initial-connection-timeout integer?] + [port port-number?] + [listen-ip (or/c false/c string?)] + [make-servlet-namespace make-servlet-namespace/c]))) \ No newline at end of file diff --git a/collects/web-server/web-config-unit.ss b/collects/web-server/web-config-unit.ss index f8c11d31cf..2b068fdd24 100644 --- a/collects/web-server/web-config-unit.ss +++ b/collects/web-server/web-config-unit.ss @@ -14,14 +14,14 @@ (#:port (or/c false/c number?) #:listen-ip (or/c false/c string?) #:make-servlet-namespace make-servlet-namespace/c) - unit?)] + (unit/c (import) (export web-config^)))] [configuration-table-sexpr->web-config@ (->* (configuration-table-sexpr?) (#:web-server-root path-string? #:port (or/c false/c number?) #:listen-ip (or/c false/c string?) #:make-servlet-namespace make-servlet-namespace/c) - unit?)]) + (unit/c (import) (export web-config^)))]) ; configuration-table->web-config@ : path -> configuration (define (configuration-table->web-config@ diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss index 1491095d57..a12a43af6d 100644 --- a/collects/web-server/web-server.ss +++ b/collects/web-server/web-server.ss @@ -14,7 +14,7 @@ (provide/contract [serve (->* (#:dispatch dispatcher/c) - (#:tcp@ unit? + (#:tcp@ (unit/c (import) (export tcp^)) #:port number? #:listen-ip (or/c false/c string?) #:max-waiting number? @@ -22,7 +22,7 @@ (-> void))] [serve/ports (->* (#:dispatch dispatcher/c) - (#:tcp@ unit? + (#:tcp@ (unit/c (import) (export tcp^)) #:ports (listof number?) #:listen-ip (or/c false/c string?) #:max-waiting number? @@ -30,13 +30,13 @@ (-> void))] [serve/ips+ports (->* (#:dispatch dispatcher/c) - (#:tcp@ unit? + (#:tcp@ (unit/c (import) (export tcp^)) #:ips+ports (listof (cons/c (or/c false/c string?) (listof number?))) #:max-waiting number? #:initial-connection-timeout number?) (-> void))] [do-not-return (-> void)] - [serve/web-config@ ((unit?) (#:tcp@ unit?) . ->* . (-> void?))]) + [serve/web-config@ (((unit/c (import) (export web-config^))) (#:tcp@ (unit/c (import) (export tcp^))) . ->* . (-> void?))]) (define (do-not-return) (semaphore-wait (make-semaphore 0))) From 76853279c39d50682ac8dc16e81b444401a3800d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 17 Feb 2009 22:11:39 +0000 Subject: [PATCH 028/142] Moved to SU3 svn: r13712 --- .../tests/web-server/all-web-server-tests.ss | 2 +- .../configuration/all-configuration-tests.ss | 2 +- .../configuration/configuration-table-test.ss | 2 +- .../dispatchers/all-dispatchers-tests.ss | 2 +- .../dispatchers/dispatch-files-test.ss | 16 ++++++++++------ .../web-server/dispatchers/dispatch-host-test.ss | 3 +-- .../web-server/dispatchers/dispatch-lang-test.ss | 2 +- .../dispatchers/dispatch-passwords-test.ss | 3 +-- .../dispatchers/dispatch-servlets-test.ss | 2 +- .../dispatchers/filesystem-map-test.ss | 2 +- .../web-server/dispatchers/servlet-test-util.ss | 2 +- collects/tests/web-server/formlets-test.ss | 2 +- collects/tests/web-server/http/all-http-tests.ss | 2 +- collects/tests/web-server/http/cookies-test.ss | 6 +++--- .../tests/web-server/http/digest-auth-test.ss | 2 +- collects/tests/web-server/lang-test.ss | 4 ++-- .../tests/web-server/lang/abort-resume-test.ss | 3 +-- collects/tests/web-server/lang/all-lang-tests.ss | 2 +- collects/tests/web-server/lang/anormal-test.ss | 2 +- collects/tests/web-server/lang/defun-test.ss | 2 +- collects/tests/web-server/lang/file-box-test.ss | 2 +- collects/tests/web-server/lang/labels-test.ss | 2 +- collects/tests/web-server/lang/stuff-url-test.ss | 2 +- collects/tests/web-server/lang/web-param-test.ss | 2 +- .../web-server/managers/all-managers-tests.ss | 2 +- .../web-server/private/all-private-tests.ss | 2 +- .../tests/web-server/private/cache-table-test.ss | 2 +- .../private/connection-manager-test.ss | 2 +- .../web-server/private/define-closure-test.ss | 2 +- collects/tests/web-server/private/gzip-test.ss | 2 +- .../tests/web-server/private/mime-types-test.ss | 2 +- .../tests/web-server/private/mod-map-test.ss | 2 +- .../tests/web-server/private/request-test.ss | 3 +-- .../tests/web-server/private/response-test.ss | 3 +-- .../tests/web-server/private/session-test.ss | 2 +- .../tests/web-server/private/url-param-test.ss | 2 +- collects/tests/web-server/private/util-test.ss | 2 +- collects/tests/web-server/run-all-tests.ss | 5 ++--- collects/tests/web-server/servlet-env-test.ss | 2 +- .../web-server/servlet/all-servlet-tests.ss | 2 +- .../tests/web-server/servlet/basic-auth-test.ss | 2 +- .../tests/web-server/servlet/bindings-test.ss | 2 +- .../tests/web-server/servlet/helpers-test.ss | 2 +- collects/tests/web-server/servlet/web-test.ss | 3 +-- collects/tests/web-server/stuffers-test.ss | 2 +- collects/tests/web-server/util.ss | 8 +++++--- 46 files changed, 63 insertions(+), 64 deletions(-) diff --git a/collects/tests/web-server/all-web-server-tests.ss b/collects/tests/web-server/all-web-server-tests.ss index 73a0cf1bf8..ea44c8a081 100644 --- a/collects/tests/web-server/all-web-server-tests.ss +++ b/collects/tests/web-server/all-web-server-tests.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "configuration/all-configuration-tests.ss" "dispatchers/all-dispatchers-tests.ss" "lang/all-lang-tests.ss" diff --git a/collects/tests/web-server/configuration/all-configuration-tests.ss b/collects/tests/web-server/configuration/all-configuration-tests.ss index 5282587ae5..3de7a213ba 100644 --- a/collects/tests/web-server/configuration/all-configuration-tests.ss +++ b/collects/tests/web-server/configuration/all-configuration-tests.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "configuration-table-test.ss") (provide all-configuration-tests) diff --git a/collects/tests/web-server/configuration/configuration-table-test.ss b/collects/tests/web-server/configuration/configuration-table-test.ss index fb48463129..6018612f07 100644 --- a/collects/tests/web-server/configuration/configuration-table-test.ss +++ b/collects/tests/web-server/configuration/configuration-table-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) (only-in mzlib/file make-temporary-file) web-server/configuration/configuration-table) diff --git a/collects/tests/web-server/dispatchers/all-dispatchers-tests.ss b/collects/tests/web-server/dispatchers/all-dispatchers-tests.ss index 79d213922e..6d3e761478 100644 --- a/collects/tests/web-server/dispatchers/all-dispatchers-tests.ss +++ b/collects/tests/web-server/dispatchers/all-dispatchers-tests.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "dispatch-passwords-test.ss" "dispatch-files-test.ss" "dispatch-servlets-test.ss" diff --git a/collects/tests/web-server/dispatchers/dispatch-files-test.ss b/collects/tests/web-server/dispatchers/dispatch-files-test.ss index 35b481cbba..e4080c4e37 100644 --- a/collects/tests/web-server/dispatchers/dispatch-files-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-files-test.ss @@ -1,5 +1,5 @@ -#lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +#lang scheme +(require (planet schematics/schemeunit:3) (only-in mzlib/file file-name-from-path make-temporary-file) @@ -45,10 +45,14 @@ (test-case "read-range-header: missing and badly formed headers" (check-false (files:read-range-header (list (make-header #"Ranges" #"bytes=1-10"))) "check 1") - (check-false (files:read-range-header (list (make-header #"Range" #"completely wrong"))) "check 2") - (check-false (files:read-range-header (list (make-header #"Range" #"byte=1-10"))) "check 3") - (check-false (files:read-range-header (list (make-header #"Range" #"bytes=a-10"))) "check 4") - (check-false (files:read-range-header (list (make-header #"Range" #"bytes=1-1.0"))) "check 5")) + (check-false (parameterize ([current-error-port (open-output-nowhere)]) + (files:read-range-header (list (make-header #"Range" #"completely wrong")))) "check 2") + (check-false (parameterize ([current-error-port (open-output-nowhere)]) + (files:read-range-header (list (make-header #"Range" #"byte=1-10")))) "check 3") + (check-false (parameterize ([current-error-port (open-output-nowhere)]) + (files:read-range-header (list (make-header #"Range" #"bytes=a-10")))) "check 4") + (check-false (parameterize ([current-error-port (open-output-nowhere)]) + (files:read-range-header (list (make-header #"Range" #"bytes=1-1.0")))) "check 5")) (test-case "read-range-header: single range" diff --git a/collects/tests/web-server/dispatchers/dispatch-host-test.ss b/collects/tests/web-server/dispatchers/dispatch-host-test.ss index b04c459cec..1ec05a0d04 100644 --- a/collects/tests/web-server/dispatchers/dispatch-host-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-host-test.ss @@ -1,6 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (planet "util.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) (only-in mzlib/file make-temporary-file) net/url diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss index b15b37623f..f80795a9cc 100644 --- a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0)) mzlib/etc mzlib/list diff --git a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss index 19be134a59..5f0325ee08 100644 --- a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss @@ -1,6 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (planet "util.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) (only-in mzlib/file make-temporary-file) net/url diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index dbfb5b1322..cb96d59275 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0)) mzlib/etc mzlib/list diff --git a/collects/tests/web-server/dispatchers/filesystem-map-test.ss b/collects/tests/web-server/dispatchers/filesystem-map-test.ss index 2597c326ae..9059091c6b 100644 --- a/collects/tests/web-server/dispatchers/filesystem-map-test.ss +++ b/collects/tests/web-server/dispatchers/filesystem-map-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) net/url web-server/private/util web-server/dispatchers/filesystem-map) diff --git a/collects/tests/web-server/dispatchers/servlet-test-util.ss b/collects/tests/web-server/dispatchers/servlet-test-util.ss index 37db1dfbcf..225e95310b 100644 --- a/collects/tests/web-server/dispatchers/servlet-test-util.ss +++ b/collects/tests/web-server/dispatchers/servlet-test-util.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0)) mzlib/list web-server/http diff --git a/collects/tests/web-server/formlets-test.ss b/collects/tests/web-server/formlets-test.ss index 9f12129485..c466f4a7ab 100644 --- a/collects/tests/web-server/formlets-test.ss +++ b/collects/tests/web-server/formlets-test.ss @@ -1,5 +1,5 @@ #lang scheme -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) net/url web-server/http web-server/formlets diff --git a/collects/tests/web-server/http/all-http-tests.ss b/collects/tests/web-server/http/all-http-tests.ss index 3ca82a429c..d4b0a037b8 100644 --- a/collects/tests/web-server/http/all-http-tests.ss +++ b/collects/tests/web-server/http/all-http-tests.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "cookies-test.ss" "digest-auth-test.ss") (provide all-http-tests) diff --git a/collects/tests/web-server/http/cookies-test.ss b/collects/tests/web-server/http/cookies-test.ss index fa25ae829f..10d3831fb4 100644 --- a/collects/tests/web-server/http/cookies-test.ss +++ b/collects/tests/web-server/http/cookies-test.ss @@ -1,5 +1,5 @@ #lang scheme -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) net/url web-server/http/request-structs web-server/http/response-structs @@ -57,11 +57,11 @@ "xexpr-response/cookies" (test-equal? "Simple" (response/full-body (xexpr-response/cookies empty `(html))) - (list #"")) + (list #"")) (test-equal? "One (body)" (response/full-body (xexpr-response/cookies (list (make-cookie "name" "value")) `(html))) - (list #"")) + (list #"")) (test-equal? "One (headers)" (map (lambda (h) (cons (header-field h) (header-value h))) diff --git a/collects/tests/web-server/http/digest-auth-test.ss b/collects/tests/web-server/http/digest-auth-test.ss index 6e545c2aea..1da759b525 100644 --- a/collects/tests/web-server/http/digest-auth-test.ss +++ b/collects/tests/web-server/http/digest-auth-test.ss @@ -1,5 +1,5 @@ #lang scheme -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/http net/url) (provide digest-auth-tests) diff --git a/collects/tests/web-server/lang-test.ss b/collects/tests/web-server/lang-test.ss index 1cc0be72dd..a53a562217 100644 --- a/collects/tests/web-server/lang-test.ss +++ b/collects/tests/web-server/lang-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "util.ss") (provide lang-tests) @@ -240,7 +240,7 @@ (let* ([first-key (table-01-eval '(dispatch-start start 'foo))] [second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))] [third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))]) - (printf "~S~n" (list first-key second-key third-key)) + #;(printf "~S~n" (list first-key second-key third-key)) (check = 3 (table-01-eval `(dispatch lookup-k '(,second-key 2)))) (check = 4 (table-01-eval `(dispatch lookup-k '(,second-key 3)))) (check-true (zero? (table-01-eval `(dispatch lookup-k '(,second-key -1))))) diff --git a/collects/tests/web-server/lang/abort-resume-test.ss b/collects/tests/web-server/lang/abort-resume-test.ss index b30891e6e7..c9d1c320ec 100644 --- a/collects/tests/web-server/lang/abort-resume-test.ss +++ b/collects/tests/web-server/lang/abort-resume-test.ss @@ -1,6 +1,5 @@ #lang scheme -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (planet "util.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/lang/abort-resume) (require/expose web-server/lang/abort-resume (web-prompt)) (provide abort-resume-tests) diff --git a/collects/tests/web-server/lang/all-lang-tests.ss b/collects/tests/web-server/lang/all-lang-tests.ss index f75fc2afc9..2f7af74d49 100644 --- a/collects/tests/web-server/lang/all-lang-tests.ss +++ b/collects/tests/web-server/lang/all-lang-tests.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "abort-resume-test.ss" "anormal-test.ss" "defun-test.ss" diff --git a/collects/tests/web-server/lang/anormal-test.ss b/collects/tests/web-server/lang/anormal-test.ss index 56202f7cf7..8651ffe3b6 100644 --- a/collects/tests/web-server/lang/anormal-test.ss +++ b/collects/tests/web-server/lang/anormal-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/lang/anormal web-server/lang/util) (provide anormal-tests) diff --git a/collects/tests/web-server/lang/defun-test.ss b/collects/tests/web-server/lang/defun-test.ss index be3b2b9259..7b1e17b954 100644 --- a/collects/tests/web-server/lang/defun-test.ss +++ b/collects/tests/web-server/lang/defun-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/lang/defun web-server/lang/util) (provide defun-tests) diff --git a/collects/tests/web-server/lang/file-box-test.ss b/collects/tests/web-server/lang/file-box-test.ss index 2cb4fef533..fefb26b73c 100644 --- a/collects/tests/web-server/lang/file-box-test.ss +++ b/collects/tests/web-server/lang/file-box-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/lang/file-box (only-in mzlib/file make-temporary-file)) (provide file-box-tests) diff --git a/collects/tests/web-server/lang/labels-test.ss b/collects/tests/web-server/lang/labels-test.ss index cf8ee4db2f..f261c55ef8 100644 --- a/collects/tests/web-server/lang/labels-test.ss +++ b/collects/tests/web-server/lang/labels-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/lang/labels) (provide labels-tests) diff --git a/collects/tests/web-server/lang/stuff-url-test.ss b/collects/tests/web-server/lang/stuff-url-test.ss index 0f936bd836..70521c87d9 100644 --- a/collects/tests/web-server/lang/stuff-url-test.ss +++ b/collects/tests/web-server/lang/stuff-url-test.ss @@ -1,7 +1,7 @@ #lang scheme/base (require web-server/lang/stuff-url web-server/stuffers - (planet "test.ss" ("schematics" "schemeunit.plt" 2)) + (planet schematics/schemeunit:3) net/url mzlib/serialize "../util.ss") diff --git a/collects/tests/web-server/lang/web-param-test.ss b/collects/tests/web-server/lang/web-param-test.ss index a31cedd9ab..072efce82d 100644 --- a/collects/tests/web-server/lang/web-param-test.ss +++ b/collects/tests/web-server/lang/web-param-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "../util.ss") (provide web-param-tests) diff --git a/collects/tests/web-server/managers/all-managers-tests.ss b/collects/tests/web-server/managers/all-managers-tests.ss index c7d44bba43..b2b0b2542c 100644 --- a/collects/tests/web-server/managers/all-managers-tests.ss +++ b/collects/tests/web-server/managers/all-managers-tests.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))) +(require (planet schematics/schemeunit:3)) (provide all-managers-tests) (define all-managers-tests diff --git a/collects/tests/web-server/private/all-private-tests.ss b/collects/tests/web-server/private/all-private-tests.ss index 4dcc5803aa..6646557df1 100644 --- a/collects/tests/web-server/private/all-private-tests.ss +++ b/collects/tests/web-server/private/all-private-tests.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "request-test.ss" "cache-table-test.ss" "response-test.ss" diff --git a/collects/tests/web-server/private/cache-table-test.ss b/collects/tests/web-server/private/cache-table-test.ss index 071d55a33e..de88a4ec96 100644 --- a/collects/tests/web-server/private/cache-table-test.ss +++ b/collects/tests/web-server/private/cache-table-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/private/cache-table) (provide cache-table-tests) diff --git a/collects/tests/web-server/private/connection-manager-test.ss b/collects/tests/web-server/private/connection-manager-test.ss index 75dc98384e..5e6a458dfa 100644 --- a/collects/tests/web-server/private/connection-manager-test.ss +++ b/collects/tests/web-server/private/connection-manager-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/private/connection-manager) (provide connection-manager-tests) diff --git a/collects/tests/web-server/private/define-closure-test.ss b/collects/tests/web-server/private/define-closure-test.ss index 75b602edfd..5bb26814f1 100644 --- a/collects/tests/web-server/private/define-closure-test.ss +++ b/collects/tests/web-server/private/define-closure-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) mzlib/serialize mzlib/match web-server/private/define-closure) diff --git a/collects/tests/web-server/private/gzip-test.ss b/collects/tests/web-server/private/gzip-test.ss index f020089a4d..c1969af515 100644 --- a/collects/tests/web-server/private/gzip-test.ss +++ b/collects/tests/web-server/private/gzip-test.ss @@ -1,5 +1,5 @@ #lang scheme -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/private/gzip) (provide gzip-tests) diff --git a/collects/tests/web-server/private/mime-types-test.ss b/collects/tests/web-server/private/mime-types-test.ss index 56ba00cbbe..85c6c64cc3 100644 --- a/collects/tests/web-server/private/mime-types-test.ss +++ b/collects/tests/web-server/private/mime-types-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) (only-in mzlib/file make-temporary-file) web-server/http web-server/private/mime-types) diff --git a/collects/tests/web-server/private/mod-map-test.ss b/collects/tests/web-server/private/mod-map-test.ss index ecb1328465..d4c45dc127 100644 --- a/collects/tests/web-server/private/mod-map-test.ss +++ b/collects/tests/web-server/private/mod-map-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/private/mod-map mzlib/serialize "../util.ss") diff --git a/collects/tests/web-server/private/request-test.ss b/collects/tests/web-server/private/request-test.ss index 6dfced3bfd..2998634914 100644 --- a/collects/tests/web-server/private/request-test.ss +++ b/collects/tests/web-server/private/request-test.ss @@ -1,6 +1,5 @@ #lang scheme -(require (planet "util.ss" ("schematics" "schemeunit.plt" 2)) - (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/private/connection-manager web-server/private/timer web-server/http) diff --git a/collects/tests/web-server/private/response-test.ss b/collects/tests/web-server/private/response-test.ss index a2575c32e0..b5305ca7a5 100644 --- a/collects/tests/web-server/private/response-test.ss +++ b/collects/tests/web-server/private/response-test.ss @@ -1,6 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (planet "util.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) xml/xml (only-in mzlib/file make-temporary-file) diff --git a/collects/tests/web-server/private/session-test.ss b/collects/tests/web-server/private/session-test.ss index b2597ef20a..2d8882d494 100644 --- a/collects/tests/web-server/private/session-test.ss +++ b/collects/tests/web-server/private/session-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) mzlib/list net/url web-server/private/session) diff --git a/collects/tests/web-server/private/url-param-test.ss b/collects/tests/web-server/private/url-param-test.ss index a7a1f6f8eb..3c134259f0 100644 --- a/collects/tests/web-server/private/url-param-test.ss +++ b/collects/tests/web-server/private/url-param-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) net/url web-server/private/url-param) (provide url-param-tests) diff --git a/collects/tests/web-server/private/util-test.ss b/collects/tests/web-server/private/util-test.ss index c8d1feccf5..bd28d4a886 100644 --- a/collects/tests/web-server/private/util-test.ss +++ b/collects/tests/web-server/private/util-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) net/url xml/xml mzlib/contract diff --git a/collects/tests/web-server/run-all-tests.ss b/collects/tests/web-server/run-all-tests.ss index 290f2b7fbf..9aa2ce4abf 100644 --- a/collects/tests/web-server/run-all-tests.ss +++ b/collects/tests/web-server/run-all-tests.ss @@ -1,6 +1,5 @@ #lang scheme/base -(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2)) - (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3/text-ui) "all-web-server-tests.ss") -(test/graphical-ui all-web-server-tests) +(run-tests all-web-server-tests) diff --git a/collects/tests/web-server/servlet-env-test.ss b/collects/tests/web-server/servlet-env-test.ss index f450d730c8..cd3766f31a 100644 --- a/collects/tests/web-server/servlet-env-test.ss +++ b/collects/tests/web-server/servlet-env-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) #;(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3)) ssax:xml->sxml) #;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4)) diff --git a/collects/tests/web-server/servlet/all-servlet-tests.ss b/collects/tests/web-server/servlet/all-servlet-tests.ss index a8097822aa..898aa16ad8 100644 --- a/collects/tests/web-server/servlet/all-servlet-tests.ss +++ b/collects/tests/web-server/servlet/all-servlet-tests.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) "bindings-test.ss" "basic-auth-test.ss" "helpers-test.ss" diff --git a/collects/tests/web-server/servlet/basic-auth-test.ss b/collects/tests/web-server/servlet/basic-auth-test.ss index 74525a02d6..33f3eedf68 100644 --- a/collects/tests/web-server/servlet/basic-auth-test.ss +++ b/collects/tests/web-server/servlet/basic-auth-test.ss @@ -1,5 +1,5 @@ #lang scheme -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/http net/url) (provide basic-auth-tests) diff --git a/collects/tests/web-server/servlet/bindings-test.ss b/collects/tests/web-server/servlet/bindings-test.ss index 26f61926da..343e6f10f1 100644 --- a/collects/tests/web-server/servlet/bindings-test.ss +++ b/collects/tests/web-server/servlet/bindings-test.ss @@ -1,5 +1,5 @@ #lang scheme -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) mzlib/list net/url web-server/http diff --git a/collects/tests/web-server/servlet/helpers-test.ss b/collects/tests/web-server/servlet/helpers-test.ss index f345d23e9c..17c105462d 100644 --- a/collects/tests/web-server/servlet/helpers-test.ss +++ b/collects/tests/web-server/servlet/helpers-test.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/servlet) (provide helpers-tests) diff --git a/collects/tests/web-server/servlet/web-test.ss b/collects/tests/web-server/servlet/web-test.ss index 1dac07efac..8caee36c94 100644 --- a/collects/tests/web-server/servlet/web-test.ss +++ b/collects/tests/web-server/servlet/web-test.ss @@ -1,6 +1,5 @@ #lang scheme/base -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (planet "util.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) net/url web-server/servlet/web) (require/expose web-server/servlet/web diff --git a/collects/tests/web-server/stuffers-test.ss b/collects/tests/web-server/stuffers-test.ss index 5036b080bc..7198a58e25 100644 --- a/collects/tests/web-server/stuffers-test.ss +++ b/collects/tests/web-server/stuffers-test.ss @@ -1,5 +1,5 @@ #lang scheme -(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) +(require (planet schematics/schemeunit:3) web-server/stuffers web-server/private/servlet web-server/http diff --git a/collects/tests/web-server/util.ss b/collects/tests/web-server/util.ss index 007be21461..22b4ebbcfd 100644 --- a/collects/tests/web-server/util.ss +++ b/collects/tests/web-server/util.ss @@ -23,7 +23,7 @@ (match (regexp-match #"^.+\r\n\r\n(.+)$" bs) [(list _ s) (define sx (ssax:xml->sxml (open-input-bytes s) empty)) - (pretty-print sx) + #;(pretty-print sx) sx] [_ (error 'html "Given ~S~n" bs)])) @@ -107,7 +107,8 @@ (eval '(require 'm-id))) (lambda (s-expr) - (parameterize ([current-namespace ns]) + (parameterize ([current-namespace ns] + [current-output-port (open-output-nowhere)]) (eval s-expr))))] [else (raise-syntax-error #f "make-module-evel: dropped through" m-expr)])) @@ -121,5 +122,6 @@ (namespace-require 'mzlib/serialize) (namespace-require pth)) (lambda (expr) - (parameterize ([current-namespace ns]) + (parameterize ([current-namespace ns] + [current-output-port (open-output-nowhere)]) (eval expr))))) From 770aab6700fb29dd8502004f7b47f006ed8859ed Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 23:38:46 +0000 Subject: [PATCH 029/142] Move first-order checks for free-var ctcs to before the body of the with-contract expansion. svn: r13713 --- collects/scheme/private/contract.ss | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index f3e2731138..00e7b49274 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -329,10 +329,19 @@ improve method arity mismatch contract violation error messages? [(marked-u ...) (map marker unprotected)]) (quasisyntax/loc stx (begin - (define-values (free-ctc-id ...) - (values (verify-contract 'with-contract free-ctc) ...)) + (define-values (free-ctc-id ... ctc-id ...) + (values (verify-contract 'with-contract free-ctc) ... + (verify-contract 'with-contract ctc) ...)) (define blame-id (current-contract-region)) + (define-values () + (begin (-contract free-ctc-id + free-var + blame-id + 'cant-happen + free-src-info) + ... + (values))) (define-syntaxes (free-var-id ...) (values (make-free-var-transformer (quote-syntax free-var) @@ -341,19 +350,13 @@ improve method arity mismatch contract violation error messages? (quote-syntax blame-stx)) ...)) (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) (with-contract-helper blame-stx (marked-p ... marked-u ...) . #,(marker #'body))) - (define-values (ctc-id ...) - (values (verify-contract 'with-contract ctc) ...)) (define-values () (begin (-contract ctc-id marked-p blame-stx 'cant-happen - src-info) ... - (-contract free-ctc-id - free-var - blame-id - 'cant-happen - free-src-info) ... + src-info) + ... (values))) (define-syntaxes (u ... p ...) (values (make-rename-transformer #'marked-u) ... From 12fd4bfc56b3e266a10959d3cf7b32382cf32472 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 18 Feb 2009 00:04:32 +0000 Subject: [PATCH 030/142] stxclass: convert rhs of #:with to syntax svn: r13714 --- collects/stxclass/private/codegen.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index ba26d8c07d..4a08c7720b 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -111,8 +111,9 @@ (let ([inner (wrap-pvars (pattern-attrs p) (convert-sides rest main-var body-expr))]) - (with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))]) - #`(let ([x #,e] + (with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))] + [with-rhs (syntax/loc e with-rhs)]) + #`(let ([x (datum->syntax #f #,e (quote-syntax with-rhs))] [fail-k enclosing-fail]) #,(parse:pks (list #'x) (list (done-frontier #'x)) From 7e8816ce0f212c87e5a32433b869d0dc5ce14002 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 18 Feb 2009 02:25:45 +0000 Subject: [PATCH 031/142] * Add initial version of define-struct/contract * Allow uncontracted exports of syntax from a with-contract form. svn: r13717 --- collects/mzlib/contract.ss | 3 +- collects/scheme/private/contract.ss | 127 +++++++++++++++--- .../scribblings/reference/contracts.scrbl | 4 + collects/tests/mzscheme/contract-test.ss | 51 +++++++ 4 files changed, 163 insertions(+), 22 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index a07bee76a0..ac8a793567 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -31,7 +31,8 @@ (require (except-in scheme/private/contract define/contract - with-contract) + with-contract + define-struct/contract) scheme/private/contract-guts scheme/private/contract-ds scheme/private/contract-opt diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 00e7b49274..7fb1f48aa1 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -12,6 +12,7 @@ improve method arity mismatch contract violation error messages? (provide (rename-out [-contract contract]) recursive-contract provide/contract + define-struct/contract define/contract with-contract current-contract-region) @@ -125,7 +126,70 @@ improve method arity mismatch contract violation error messages? (syntax/loc define-stx (define/contract name+arg-list contract #:freevars () body0 body ...))])) +(define-for-syntax (ds/c-build-struct-names name fields) + (let ([name-str (symbol->string (syntax-e name))]) + (list* (datum->syntax + name + (string->symbol + (string-append "struct:" name-str))) + (datum->syntax + name + (string->symbol + (string-append "make-" name-str))) + (datum->syntax + name + (string->symbol + (string-append name-str "?"))) + (for/list ([field-str (map (compose symbol->string syntax-e) fields)]) + (datum->syntax + name + (string->symbol + (string-append name-str "-" field-str))))))) +(define-syntax (define-struct/contract stx) + (syntax-case stx () + [(_ name ([field ctc] ...)) + (let ([fields (syntax->list #'(field ...))]) + (unless (identifier? #'name) + (raise-syntax-error 'define-struct/contract + "expected identifier for struct name" + #'name)) + (for-each (λ (f) + (unless (identifier? f) + (raise-syntax-error 'define-struct/contract + "expected identifier for field name" + f))) + fields) + (let* ([names (ds/c-build-struct-names #'name fields)] + [pred (caddr names)] + [ctcs (list* (syntax/loc stx + (-> ctc ... any/c)) + (syntax/loc stx any/c) + (let ([field-ctc (quasisyntax/loc stx + (-> #,pred any/c))]) + (build-list + (length fields) + (λ (_) field-ctc))))]) + (with-syntax ([struct:name (car names)] + [(id/ctc ...) (map list (cdr names) ctcs)]) + (syntax/loc stx + (with-contract #:type struct name + (name struct:name id/ctc ...) + (define-struct name (field ...) + #:guard (λ (field ... struct-name) + (unless (eq? 'name struct-name) + (error (format "Cannot create subtype ~a of contracted struct ~a" + struct-name 'name))) + (values field ...))))))))] + [(_ name . bad-fields) + (identifier? #'name) + (raise-syntax-error 'define-struct/contract + "expected a list of field name/contract pairs" + #'bad-fields)] + [(_ . body) + (raise-syntax-error 'define-struct/contract + "expected a structure name" + #'body)])) ; ; @@ -180,35 +244,55 @@ improve method arity mismatch contract violation error messages? (define-syntax (with-contract-helper stx) (syntax-case stx () - [(_ blame-stx ()) + [(_ blame-stx () ()) (begin #'(define-values () (values)))] - [(_ blame-stx (i0 i ...)) + [(_ blame-stx (p0 p ...) (u ...)) (raise-syntax-error 'with-contract "no definition found for identifier" - #'i0)] - [(_ blame-stx (i ...) body0 body ...) + #'p0)] + [(_ blame-stx () (u0 u ...)) + (raise-syntax-error 'with-contract + "no definition found for identifier" + #'u0)] + [(_ blame-stx (p ...) (u ...) body0 body ...) (let ([expanded-body0 (local-expand #'body0 (syntax-local-context) (kernel-form-identifier-list))]) - (syntax-case expanded-body0 (begin define-values) + (define (filter-ids to-filter to-remove) + (filter (λ (i1) + (not (memf (λ (i2) + (bound-identifier=? i1 i2)) + to-remove))) + to-filter)) + (syntax-case expanded-body0 (begin define-values define-syntaxes) [(begin sub ...) (syntax/loc stx - (with-contract-helper blame-stx (i ...) sub ... body ...))] + (with-contract-helper blame-stx (p ...) (u ...) sub ... body ...))] + [(define-syntaxes (id ...) expr) + (let ([ids (syntax->list #'(id ...))]) + (for ([i1 (syntax->list #'(p ...))]) + (when (ormap (λ (i2) + (bound-identifier=? i1 i2)) + ids) + (raise-syntax-error 'with-contract + "cannot export syntax with a contract" + i1))) + (with-syntax ([def expanded-body0] + [unused-us (filter-ids (syntax->list #'(u ...)) ids)]) + (with-syntax () + (syntax/loc stx + (begin def (with-contract-helper blame-stx (p ...) unused-us body ...))))))] [(define-values (id ...) expr) - (with-syntax ([def expanded-body0] - [unused-is (let ([ids (syntax->list #'(id ...))]) - (filter (λ (i1) - (not (ormap (λ (i2) - (bound-identifier=? i1 i2)) - ids))) - (syntax->list #'(i ...))))]) - (with-syntax () + (let ([ids (syntax->list #'(id ...))]) + (with-syntax ([def expanded-body0] + [unused-ps (filter-ids (syntax->list #'(p ...)) ids)] + [unused-us (filter-ids (syntax->list #'(u ...)) ids)]) (syntax/loc stx - (begin def (with-contract-helper blame-stx unused-is body ...)))))] + (begin def (with-contract-helper blame-stx unused-ps unused-us body ...)))))] [else (quasisyntax/loc stx (begin #,expanded-body0 - (with-contract-helper blame-stx (i ...) body ...)))]))])) + (with-contract-helper blame-stx (p ...) (u ...) body ...)))]))])) (define-for-syntax (check-and-split-with-contracts single-allowed? args) (let loop ([args args] @@ -321,7 +405,7 @@ improve method arity mismatch contract violation error messages? [(ctc-id ...) (map (λ (i) (marker (a:mangle-id stx "with-contract-contract-id" i))) protected)] - [(ctc ...) protections] + [(ctc ...) (map marker protections)] [(p ...) protected] [(marked-p ...) (map marker protected)] [(src-info ...) (map id->contract-src-info protected)] @@ -329,9 +413,8 @@ improve method arity mismatch contract violation error messages? [(marked-u ...) (map marker unprotected)]) (quasisyntax/loc stx (begin - (define-values (free-ctc-id ... ctc-id ...) - (values (verify-contract 'with-contract free-ctc) ... - (verify-contract 'with-contract ctc) ...)) + (define-values (free-ctc-id ...) + (values (verify-contract 'with-contract free-ctc) ...)) (define blame-id (current-contract-region)) (define-values () @@ -349,7 +432,9 @@ improve method arity mismatch contract violation error messages? (quote-syntax blame-id) (quote-syntax blame-stx)) ...)) (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) - (with-contract-helper blame-stx (marked-p ... marked-u ...) . #,(marker #'body))) + (with-contract-helper blame-stx (marked-p ...) (marked-u ...) . #,(marker #'body))) + (define-values (ctc-id ...) + (values (verify-contract 'with-contract ctc) ...)) (define-values () (begin (-contract ctc-id marked-p diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 50cff07d7c..7b02e605c6 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -720,6 +720,10 @@ inside the @scheme[body] will be protected with contracts that blame the context of the @scheme[define/contract] form for the positive positions and the @scheme[define/contract] form for the negative ones.} +@defform*[[(define-struct/contract struct-id ([field-id contract-expr] ...))]]{ +Works like @scheme[define-struct], except that the arguments to the constructor +and accessors are protected by contracts.} + @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) (contract contract-expr to-protect-expr diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index b009255492..fde5500ced 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2478,6 +2478,57 @@ "top-level") + +; +; +; +; ; ;;;; ; +; ;; ; ; ; +; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; +; ;; ; ;;; ;;;; ; ; ;; ;;; ;;; ;;;; ; ;;;; ;; ;;; ;;;; ; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;; +; ; ;; ; ; ; ;; ;;; ; ; ; ; ; ; ;;; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ; +; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; +; ; ; ; ; ; ; ; ; ;;;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ;; ; ;;; ;;;;;;;;;; ;;; ;;; ;;; ;; ;;; ;; ; ;;; ;; ; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;; +; +; +; + + (test/spec-passed + 'define-struct/contract1 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + 1)) + + (test/spec-passed + 'define-struct/contract2 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + (make-foo 1 2))) + + (test/spec-failed + 'define-struct/contract3 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + (make-foo 1 #t)) + "top-level") + + (test/spec-passed + 'define-struct/contract4 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + (foo-y (make-foo 2 3)))) + + (test/spec-failed + 'define-struct/contract5 + '(let () + (define-struct/contract foo ([x number?] [y number?])) + (foo-y 1)) + "top-level") + ; ; ; From 87f92bc33e07b4865d9def9ffa188db8120ce825 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Feb 2009 02:59:56 +0000 Subject: [PATCH 032/142] doc clarification svn: r13719 --- collects/scribblings/reference/module-reflect.scrbl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/module-reflect.scrbl b/collects/scribblings/reference/module-reflect.scrbl index 40bad5d696..801383101e 100644 --- a/collects/scribblings/reference/module-reflect.scrbl +++ b/collects/scribblings/reference/module-reflect.scrbl @@ -258,7 +258,8 @@ Returns two association lists mapping @tech{phase level} values (where the corresponding phase. The first association list is for exported variables, and the second is for exported syntax. -Each associated list more precisely matches the contract +Each associated list, which is represented by @scheme[list?] in the +result contracts above, more precisely matches the contract @schemeblock[ (listof (list/c symbol? From b6c5e2ee3d95c85b5cb26b289fc3bf7536db121d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 18 Feb 2009 03:01:31 +0000 Subject: [PATCH 033/142] wrote a little more, finished 6 svn: r13720 --- .../games/chat-noir/chat-noir-literate.ss | 108 ++++++++++-------- 1 file changed, 61 insertions(+), 47 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 441b71e983..773d13c508 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -47,7 +47,8 @@ and some code that builds an initial world and starts the game. @chunk[
(require scheme/local scheme/list scheme/bool scheme/math - (for-syntax scheme/base)) + lang/private/imageeq ;; don't like this require, but need it for image? + (for-syntax scheme/base)) (require htdp/world lang/posn scheme/contract) @@ -692,16 +693,33 @@ it returns @scheme['∞] if either argument is @scheme['∞]. @section{Drawing the Cat} +This code is three large, similar constants, +bundled up into the @scheme[cat] function. +The @scheme[thinking-cat] is the one that +is visible when the game is being played. It +differs from the others in that it does not +have a mouth. The @scheme[mad-cat] is the one +that you see when the cat loses. It differs +from the others in that its pinks turn pink. +Finally, the @scheme[happy-cat] shows up when +the cat wins and it is just like the @scheme[thinking-cat] +except it has a smile. + @chunk[ - ;; cat : symbol -> image - (define (cat mode) - (local [(define face-color + (define/contract (cat mode) + (-> (or/c 'mad 'happy 'thinking) image?) + (local [(define face-width 36) + (define face-height 22) + + (define face-color (cond - [(symbol=? mode 'sad) 'pink] + [(symbol=? mode 'mad) 'pink] [else 'lightgray])) - (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3))) - (define right-ear (regular-polygon 3 8 'solid 'black 0)) + (define left-ear + (regular-polygon 3 8 'solid 'black (/ pi -3))) + (define right-ear + (regular-polygon 3 8 'solid 'black 0)) (define ear-x-offset 14) (define ear-y-offset 9) @@ -710,7 +728,8 @@ it returns @scheme['∞] if either argument is @scheme['∞]. (define eye-x-offset 8) (define eye-y-offset 3) - (define nose (regular-polygon 3 5 'solid 'black (/ pi 2))) + (define nose + (regular-polygon 3 5 'solid 'black (/ pi 2))) (define mouth-happy (overlay (ellipse 8 8 'solid face-color) @@ -729,36 +748,40 @@ it returns @scheme['∞] if either argument is @scheme['∞]. [(symbol=? mode 'happy) mouth-happy] [else mouth-no-expression])) (define mouth-x-offset 4) - (define mouth-y-offset -5)] - - (add-line - (add-line - (add-line - (add-line - (add-line - (add-line - (overlay (move-pinhole left-ear (- ear-x-offset) ear-y-offset) - (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) - (ellipse 40 26 'solid 'black) - (ellipse 36 22 'solid face-color) - (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) - (move-pinhole mouth mouth-x-offset mouth-y-offset) - (move-pinhole eye (- eye-x-offset) eye-y-offset) - (move-pinhole eye eye-x-offset eye-y-offset) - (move-pinhole nose -1 -4)) - 6 4 30 12 'black) - 6 4 30 4 'black) - 6 4 30 -4 'black) - -6 4 -30 12 'black) - -6 4 -30 4 'black) - -6 4 -30 -4 'black))) + (define mouth-y-offset -5) + + (define (whiskers img) + (add-line + (add-line + (add-line + (add-line + (add-line + (add-line + img + 6 4 30 12 'black) + 6 4 30 4 'black) + 6 4 30 -4 'black) + -6 4 -30 12 'black) + -6 4 -30 4 'black) + -6 4 -30 -4 'black))] + (whiskers + (overlay + (move-pinhole left-ear (- ear-x-offset) ear-y-offset) + (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) + (ellipse (+ face-width 4) (+ face-height 4) 'solid 'black) + (ellipse face-width face-height 'solid face-color) + (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) + (move-pinhole mouth mouth-x-offset mouth-y-offset) + (move-pinhole eye (- eye-x-offset) eye-y-offset) + (move-pinhole eye eye-x-offset eye-y-offset) + (move-pinhole nose -1 -4))))) + (define thinking-cat (cat 'thinking)) (define happy-cat (cat 'happy)) - (define sad-cat (cat 'sad)) - (define thinking-cat (cat 'thinking))] + (define mad-cat (cat 'mad))] -@section{Drawing a World} +@section{Drawing the World} @chunk[ (define circle-radius 20) @@ -797,7 +820,7 @@ it returns @scheme['∞] if either argument is @scheme['∞]. (move-pinhole (cond [(equal? (world-state w) 'cat-won) happy-cat] - [(equal? (world-state w) 'cat-lost) sad-cat] + [(equal? (world-state w) 'cat-lost) mad-cat] [else thinking-cat]) (- (cell-center-x (world-cat w))) (- (cell-center-y (world-cat w)))))))] @@ -851,7 +874,7 @@ it returns @scheme['∞] if either argument is @scheme['∞]. 2 (lambda (x) true) false) - (move-pinhole sad-cat + (move-pinhole mad-cat (- (cell-center-x (make-posn 0 1))) (- (cell-center-y (make-posn 0 1)))))) @@ -882,7 +905,7 @@ it returns @scheme['∞] if either argument is @scheme['∞]. 3 (lambda (x) false) false) - (move-pinhole sad-cat + (move-pinhole mad-cat (- (cell-center-x (make-posn 1 1))) (- (cell-center-y (make-posn 1 1)))))) @@ -916,7 +939,7 @@ it returns @scheme['∞] if either argument is @scheme['∞]. (lambda (x) true) (make-posn (cell-center-x (make-posn 0 1)) (cell-center-y (make-posn 0 1)))) - (move-pinhole sad-cat + (move-pinhole mad-cat (- (cell-center-x (make-posn 1 1))) (- (cell-center-y (make-posn 1 1))))))] @@ -2059,15 +2082,6 @@ it returns @scheme['∞] if either argument is @scheme['∞]. ; ; -;; append-all : (listof (list X)) -> (listof X) -(define (append-all ls) - (foldr append empty ls)) - -(test (append-all empty) empty) -(test (append-all (list (list 1 2 3))) (list 1 2 3)) -(test (append-all (list (list 1) (list 2) (list 3))) - (list 1 2 3)) - ;; add-n-random-blocked-cells : number (listof cell) number -> (listof cell) (define (add-n-random-blocked-cells n all-cells board-size) (cond From 59727cc4bcdb2f4955f3f5206207a8d482736d0a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 18 Feb 2009 04:01:52 +0000 Subject: [PATCH 034/142] stxclass: added and- and or-patterns, box and vector patterns svn: r13721 --- collects/stxclass/main.ss | 5 +- collects/stxclass/private/codegen-data.ss | 36 ++- collects/stxclass/private/codegen.ss | 285 +++++++++++------- collects/stxclass/private/rep-data.ss | 18 +- collects/stxclass/private/rep.ss | 178 +++++++---- collects/stxclass/private/runtime.ss | 51 ++-- collects/stxclass/private/sc.ss | 2 + .../stxclass/scribblings/parsing-syntax.scrbl | 79 +++-- collects/tests/stxclass/stxclass.ss | 32 +- collects/typed-scheme/private/parse-type.ss | 2 +- collects/typed-scheme/private/prims.ss | 4 +- collects/typed-scheme/private/type-abbrev.ss | 2 +- collects/typed-scheme/rep/interning.ss | 4 +- collects/typed-scheme/rep/rep-utils.ss | 10 +- 14 files changed, 431 insertions(+), 277 deletions(-) diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss index ad37c75457..b8e06462a2 100644 --- a/collects/stxclass/main.ss +++ b/collects/stxclass/main.ss @@ -8,11 +8,14 @@ define-basic-syntax-class* pattern basic-syntax-class + ~and + ~or + ...* syntax-parse syntax-parser with-patterns - ...* + attribute current-expression current-macro-name diff --git a/collects/stxclass/private/codegen-data.ss b/collects/stxclass/private/codegen-data.ss index 8579caf711..77938937f4 100644 --- a/collects/stxclass/private/codegen-data.ss +++ b/collects/stxclass/private/codegen-data.ss @@ -10,19 +10,27 @@ ;; - 'fail' stxparameterized to (non-escaping!) failure procedure (define-struct pk (ps k) #:transparent) -;; An ExtPK is one of +;; A Group (G) is one of ;; - PK -;; - (make-idpks stxclass (listof stx) (listof PK)) -;; - (make-cpks (listof PK) (listof DatumPKS) (listof LiteralPKS)) -;; the first field has only pair patterns -(define-struct idpks (stxclass args idpks)) -(define-struct cpks (pairpks datumpks literalpks)) +;; - (make-idG stxclass (listof stx) (listof PK)) +;; where each PK starts with an id pattern of given stxclass/args +;; - (make-descrimG (listof DatumSG) (listof LiteralSG) (listof CompountSGs)) +;; where each DatumSG/LiteralSG/CompoundSG has a different datum/lit/kind +(define-struct idG (stxclass args idpks) #:transparent) +(define-struct descrimG (datumSGs literalSGs kindSGs) #:transparent) -;; A DatumPKS is (make-datumpks datum (listof PK)) -(define-struct datumpks (datum pks)) +;; A DatumSG is (make-datumSG datum (listof PK)) +;; where each PK starts with a datum pattern equal to datum +(define-struct datumSG (datum pks)) + +;; A LiteralSG is (make-literalSG id (listof PK)) +;; where each PK starts with a literal pattern equal to literal +(define-struct literalSG (literal pks)) + +;; A CompoundSG is (make-compoundSG Kind (listof PK)) +;; where each PK starts with a compound pattern of given kind +(define-struct compoundSG (kind pks)) -;; A LiteralPKS is (make-literalpks identifier (listof PK)) -(define-struct literalpks (literal pks)) ;; A FrontierContextExpr (FCE) is one of ;; - (make-fce Id FrontierIndexExpr) @@ -55,6 +63,11 @@ (cons (fi:add-index (car (fce-indexes fc)) expr) (cdr (fce-indexes fc))))) +(define (frontier:add-unvector fc) + (frontier:add-car fc (fce-stx fc))) +(define (frontier:add-unbox fc) + (frontier:add-car fc (fce-stx fc))) + (define (join-frontiers base ext) (make-joined-frontier base ext)) @@ -80,6 +93,7 @@ stx] [(struct joined-frontier (base ext)) #`(let ([inner-failure #,ext]) - (or (and (failed? inner-failure) (failed-frontier-stx inner-failure)) + (or (and (failed? inner-failure) + (failed-frontier-stx inner-failure)) #,(loop base)))])) (loop fc)) diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index 4a08c7720b..5bb8d59758 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -33,13 +33,14 @@ "syntax class has no variants")) (parse:pks (list #'x) (list (empty-frontier #'x)) - pks - #'fail-rhs))))] + #'fail-rhs + (list #f) + pks))))] [(rhs:basic? rhs) (rhs:basic-parser rhs)])) ;; parse:clauses : stx identifier identifier -> stx -(define (parse:clauses stx var failid) +(define (parse:clauses stx var phi) (define clauses-kw-table (list (list '#:literals check-literals-list))) (define-values (chunks clauses-stx) @@ -70,8 +71,9 @@ (wrong-syntax stx "no variants")) (parse:pks (list var) (list (empty-frontier var)) - pks - failid))) + phi + (list #f) + pks))) ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs->pks rhs relsattrs main-var) @@ -117,8 +119,9 @@ [fail-k enclosing-fail]) #,(parse:pks (list #'x) (list (done-frontier #'x)) - (list (make-pk (list p) inner)) - #'fail-k))))])) + #'fail-k + (list #f) + (list (make-pk (list p) inner))))))])) ;; success-expr : (listof IAttr) (listof SAttr) RemapEnv stx -> stx (define (success-expr iattrs relsattrs remap main-var) @@ -142,47 +145,72 @@ ;; Parsing -;; parse:pks : (listof identifier) (listof FCE) (listof PK) identifier -> stx +#| + +The parsing algorithm is based on the classic backtracking +algorithm (see Optimizing Pattern Matching for an overview). A PK +corresponds to a row in the pattern matrix. The failure argument +corresponds to the static catch continuation. + +The FCs (frontier contexts, one per column) are an addition for error +reporting. They track the matcher's progress into the term. The +matcher compares failures on backtracking, and reports the "furthest +along" failure, based on the frontiers. + +Conventions: + = + vars : listof identifiers, variables, one per column + fcs : listof FCEs, failure contexts, one per column + phi : id, failure continuation + ds : listof (string/#f), description string + +|# + + +;; parse:pks : (listof PK) -> stx ;; Each PK has a list of |vars| patterns. ;; The list of PKs must not be empty. -(define (parse:pks vars fcs pks failid) +(define (parse:pks vars fcs phi ds pks) (cond [(null? pks) (error 'parse:pks "internal error: empty list of rows")] [(null? vars) ;; Success! - (let* ([failvar (car (generate-temporaries #'(fail-k)))] + (let* ([failvar (generate-temporary 'fail-k)] [exprs (for/list ([pk pks]) #`(with-enclosing-fail #,failvar #,(pk-k pk)))]) (with-syntax ([failvar failvar] [(expr ...) exprs]) - #`(try failvar [expr ...] #,failid)))] + #`(try failvar [expr ...] #,phi)))] [else - (let-values ([(vars extpks) (split-pks vars pks)]) - (let* ([failvar (car (generate-temporaries #'(fail-k)))] + (let-values ([(vars groups) (split-pks vars pks)]) + (let* ([failvar (generate-temporary 'fail-k)] [exprs - (for/list ([extpk extpks]) - (parse:extpk vars fcs extpk failvar))]) + (for/list ([group groups]) + (parse:group vars fcs failvar ds group))]) (with-syntax ([failvar failvar] [(expr ...) exprs]) - #`(try failvar [expr ...] #,failid))))])) + #`(try failvar [expr ...] #,phi))))])) -;; parse:extpk : (listof identifier) (listof FCE) ExtPK identifier -> stx +;; parse:group : Group -> stx ;; Pre: vars is not empty -(define (parse:extpk vars fcs extpk failid) - (match extpk - [(struct idpks (stxclass args pks)) +(define (parse:group vars fcs phi ds group) + (match group + [(struct idG (stxclass args pks)) (if stxclass - (parse:pk:id/stxclass vars fcs failid stxclass args pks) - (parse:pk:id/any vars fcs failid args pks))] - [(struct cpks (pairpks datumpkss literalpkss)) - (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)] + (parse:group:id/stxclass vars fcs phi ds stxclass args pks) + (parse:group:id/any vars fcs phi ds args pks))] + [(struct descrimG (datumSGs literalSGs kindSGs)) + (parse:group:descrim vars fcs phi ds datumSGs literalSGs kindSGs)] + [(struct pk ((cons (? pat:and? and-pattern) rest-patterns) k)) + (parse:group:and vars fcs phi ds and-pattern rest-patterns k)] [(struct pk ((cons (? pat:gseq? gseq-pattern) rest-patterns) k)) - (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)])) + (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)])) -;; parse:pk:id/stxclass : (listof id) (listof FCE) id SC stx (listof pk) -> stx -(define (parse:pk:id/stxclass vars fcs failid stxclass args pks) +;; parse:group:id/stxclass : SC stx (listof pk) +;; -> stx +(define (parse:group:id/stxclass vars fcs phi ds stxclass args pks) (with-syntax ([var0 (car vars)] [(arg ...) args] [(arg-var ...) (generate-temporaries args)] @@ -191,77 +219,108 @@ #`(let ([arg-var arg] ...) (let ([result (parser var0 arg-var ...)]) (if (ok? result) - #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid) - #,(fail failid (car vars) + #,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result)) + #,(fail phi (car vars) #:pattern (expectation-of-stxclass stxclass #'(arg-var ...) #'result) #:fce (join-frontiers (car fcs) #'result))))))) -;; parse:pk:id/any : (listof id) (listof FCE) id stx (listof pk) -> stx -(define (parse:pk:id/any vars fcs failid args pks) +;; parse:group:id/any : stx (listof pk) -> stx +(define (parse:group:id/any vars fcs phi ds args pks) (with-syntax ([var0 (car vars)] [(arg ...) args] [(arg-var ...) (generate-temporaries args)] [result (generate-temporary 'result)]) #`(let ([arg-var arg] ...) (let ([result (list var0)]) - #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid))))) + #,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result)))))) -;; parse:pk:c : (listof id) (listof FCE) id ??? ... -> stx -(define (parse:pk:c vars fcs failid pairpks datumpkss literalpkss) +;; parse:group:descrim : +;; (listof DatumSG) (listof LiteralSG) (listof CompoundSG) +;; -> stx +(define (parse:group:descrim vars fcs phi ds datumSGs literalSGs compoundSGs) (define var (car vars)) (define datum-var (generate-temporary 'datum)) - (define (datumpks-test datumpks) - (let ([datum (datumpks-datum datumpks)]) + (define (datumSG-test datumSG) + (let ([datum (datumSG-datum datumSG)]) #`(equal? #,datum-var (quote #,datum)))) - (define (datumpks-rhs datumpks) - (let ([pks (datumpks-pks datumpks)]) - (parse:pks (cdr vars) (cdr fcs) (shift-pks:datum pks) failid))) - (define (literalpks-test literalpks) - (let ([literal (literalpks-literal literalpks)]) + (define (datumSG-rhs datumSG) + (let ([pks (datumSG-pks datumSG)]) + (parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:datum pks)))) + (define (literalSG-test literalSG) + (let ([literal (literalSG-literal literalSG)]) #`(and (identifier? #,var) (free-identifier=? #,var (quote-syntax #,literal))))) - (define (literalpks-rhs literalpks) - (let ([pks (literalpks-pks literalpks)]) - (parse:pks (cdr vars) (cdr fcs) (shift-pks:literal pks) failid))) + (define (literalSG-rhs literalSG) + (let ([pks (literalSG-pks literalSG)]) + (parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:literal pks)))) + (define (compoundSG-test compoundSG) + (let ([kind (compoundSG-kind compoundSG)]) + #`(#,(kind-predicate kind) #,datum-var))) + (define (compoundSG-rhs compoundSG) + (let* ([pks (compoundSG-pks compoundSG)] + [kind (compoundSG-kind compoundSG)] + [selectors (kind-selectors kind)] + [frontier-procs (kind-frontier-procs kind)] + [part-vars (for/list ([selector selectors]) (generate-temporary 'part))] + [part-frontiers + (for/list ([fproc frontier-procs] [part-var part-vars]) + (fproc (car fcs) part-var))] + [part-ds (for/list ([selector selectors]) (car ds))]) + (with-syntax ([(part-var ...) part-vars] + [(part-expr ...) + (for/list ([selector selectors]) (selector var datum-var))]) + #`(let ([part-var part-expr] ...) + #,(parse:pks (append part-vars (cdr vars)) + (append part-frontiers (cdr fcs)) + phi + (append part-ds (cdr ds)) + (shift-pks:compound pks)))))) (define-pattern-variable var0 var) (define-pattern-variable dvar0 datum-var) (define-pattern-variable head-var (generate-temporary 'head)) (define-pattern-variable tail-var (generate-temporary 'tail)) (with-syntax ([(datum-clause ...) - (for/list ([datumpks datumpkss]) - #`[#,(datumpks-test datumpks) #,(datumpks-rhs datumpks)])] + (for/list ([datumSG datumSGs]) + #`[#,(datumSG-test datumSG) #,(datumSG-rhs datumSG)])] [(lit-clause ...) - (for/list ([literalpks literalpkss]) - #`[#,(literalpks-test literalpks) #,(literalpks-rhs literalpks)])]) + (for/list ([literalSG literalSGs]) + #`[#,(literalSG-test literalSG) #,(literalSG-rhs literalSG)])] + [(compound-clause ...) + (for/list ([compoundSG compoundSGs]) + #`[#,(compoundSG-test compoundSG) #,(compoundSG-rhs compoundSG)])]) #`(let ([dvar0 (if (syntax? var0) (syntax-e var0) var0)]) - (cond #,@(if (pair? pairpks) - #`([(pair? dvar0) - (let ([head-var (car dvar0)] - [tail-var (datum->syntax var0 (cdr dvar0) var0)]) - #,(parse:pks (list* #'head-var #'tail-var (cdr vars)) - (list* (frontier:add-car (car fcs) #'head-var) - (frontier:add-cdr (car fcs)) - (cdr fcs)) - (shift-pks:pair pairpks) - failid))]) - #`()) + (cond compound-clause ... lit-clause ... datum-clause ... [else - #,(fail failid (car vars) + #,(fail phi (car vars) #:pattern (expectation-of-constants - (pair? pairpks) - (for/list ([d datumpkss]) - (datumpks-datum d)) - (for/list ([l literalpkss]) - (literalpks-literal l))) + (pair? compoundSGs) + (for/list ([d datumSGs]) + (datumSG-datum d)) + (for/list ([l literalSGs]) + (literalSG-literal l)) + (car ds)) #:fce (car fcs))])))) -;; parse:pk:gseq : (listof id) (listof FCE) id -;; pat:gseq (listof Pattern) -;; ??? -;; -> stx -(define (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k) +;; parse:gseq:and : pat:and (listof Pattern) stx +;; -> stx +(define (parse:group:and vars fcs phi ds and-pattern rest-patterns k) + (match-define (struct pat:and (orig-stx attrs depth description patterns)) + and-pattern) + ;; FIXME: handle description + (let ([var0-copies (for/list ([p patterns]) (car vars))] + [fc0-copies (for/list ([p patterns]) (car fcs))] + [ds-copies (for/list ([p patterns]) (or description (car ds)))]) + (parse:pks (append var0-copies (cdr vars)) + (append fc0-copies (cdr fcs)) + phi + (append ds-copies (cdr ds)) + (list (make pk (append patterns rest-patterns) k))))) + +;; parse:compound:gseq : pat:gseq (listof Pattern) stx +;; -> stx +(define (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k) (match-define (struct pat:gseq (orig-stx attrs depth heads tail)) gseq-pattern) (define xvar (generate-temporary 'x)) (define head-lengths (for/list ([head heads]) (length (head-ps head)))) @@ -269,9 +328,7 @@ (define hid-initss (for/list ([head heads] [head-attrs head-attrss]) (for/list ([head-attr head-attrs]) - (cond [(head-default head) - => (lambda (x) #`(quote-syntax #,x))] - [(head-as-list? head) #'null] + (cond [(head-as-list? head) #'null] [else #'#f])))) (define combinerss (for/list ([head heads] [head-attrs head-attrss]) @@ -309,9 +366,6 @@ (if maxrep #`(< #,repvar #,maxrep) #`#t))] - [(occurs-binding ...) - (for/list ([head heads] [rep reps] #:when (head-occurs head)) - #`[#,(head-occurs head) (positive? #,rep)])] [(parse-loop failkv fail-tail) (generate-temporaries #'(parse-loop failkv fail-tail))]) @@ -344,12 +398,12 @@ #`(cond minrep-clause ... [else (let ([hid (finalize hid-arg)] ... ... - occurs-binding ... [fail-tail enclosing-fail]) #,(parse:pks (cdr vars) (cdr fcs) - (list (make-pk rest-patterns k)) - #'fail-tail))]))) + #'fail-tail + (cdr ds) + (list (make-pk rest-patterns k))))]))) (with-syntax ([tail-rhs tail-rhs-expr] [(rhs ...) @@ -366,31 +420,33 @@ #,(parse:pks (list #'x) (list (frontier:add-index (car fcs) #'(calculate-index rep ...))) + #'failkv + (list (car ds)) (append (map make-pk (map list completed-heads) (syntax->list #'(rhs ...))) - (list (make-pk (list tail) #`tail-rhs))) - #'failkv)) + (list (make-pk (list tail) #`tail-rhs))))) (let ([hid hid-init] ... ... [rep 0] ...) - (parse-loop var0 hid ... ... rep ... #,failid)))))) - + (parse-loop var0 hid ... ... rep ... #,phi)))))) ;; complete-heads-patterns : Head identifier number stx -> Pattern (define (complete-heads-pattern head rest-var depth seq-orig-stx) (define (loop ps pat) (if (pair? ps) - (make-pat:pair (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat)) - (append (pattern-attrs (car ps)) (pattern-attrs pat)) - depth - (car ps) - (loop (cdr ps) pat)) + (make pat:compound + (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat)) + (append (pattern-attrs (car ps)) (pattern-attrs pat)) + depth + pairK + (list (car ps) (loop (cdr ps) pat))) pat)) (define base - (make-pat:id seq-orig-stx - (list (make-attr rest-var depth null)) - depth rest-var #f null)) + (make pat:id + seq-orig-stx + (list (make-attr rest-var depth null)) + depth rest-var #f null)) (loop (head-ps head) base)) ;; split-pks : (listof identifier) (listof PK) @@ -406,7 +462,7 @@ (define (split-pks/first-column pks) (define (get-pat x) (car (pk-ps x))) (define (constructor-pat? p) - (or (pat:pair? p) (pat:datum? p) (pat:literal? p))) + (or (pat:compound? p) (pat:datum? p) (pat:literal? p))) (define (constructor-pk? pk) (constructor-pat? (get-pat pk))) (define (id-pk? pk) @@ -453,13 +509,17 @@ (pat:id? p2) (and (pat:datum? p1) (pat:datum? p2) (equal? (pat:datum-datum p1) (pat:datum-datum p2))) - (and (pat:pair? p1) (pat:pair? p2) - (pattern-intersects? (pat:pair-head p1) (pat:pair-head p2)) - (pattern-intersects? (pat:pair-tail p1) (pat:pair-tail p2))) + (and (pat:compound? p1) (pat:compound? p2) + (eq? (pat:compound-kind p1) (pat:compound-kind p2)) + (andmap pattern-intersects? + (pat:compound-patterns p1) + (pat:compound-patterns p2))) ;; FIXME: conservative (and (pat:literal? p1) (pat:literal? p2)) (pat:gseq? p1) - (pat:gseq? p2))) + (pat:gseq? p2) + (pat:and? p1) + (pat:and? p2))) (define (major-loop pks epks) (match pks @@ -481,18 +541,17 @@ tail (list head) null)]) - (let ([id-epk (make idpks this-stxclass this-args (reverse r-id-pks))]) + (let ([id-epk (make idG this-stxclass this-args (reverse r-id-pks))]) (major-loop tail (cons id-epk epks)))))] + ;; Leave gseq- and and-patterns by themselves (at least for now) [(cons head tail) (major-loop tail (cons head epks))])) ;; gather : (PK -> boolean) (listof PK) (listof PK) (listof PK) ;; -> (listof PK) (listof PK) (define (gather pred pks taken prefix) - #;(printf "called gather (~s pks, ~s prefix)\n" (length pks) (length prefix)) (match pks ['() - #;(printf "took ~s, left ~s\n" (length taken) (length prefix)) (values taken (reverse prefix))] [(cons pk tail) ;; We can have it if it can move past everything in the prefix. @@ -504,16 +563,18 @@ ;; group-constructor-pks : (listof PK) -> ExtPK (define (group-constructor-pks reversed-pks) - (define pairpks null) - (define ht (make-hash)) + (define compound-ht (make-hasheq)) + (define datum-ht (make-hash)) (define lit-ht (make-bound-identifier-mapping)) (for ([pk reversed-pks]) (let ([p (get-pat pk)]) - (cond [(pat:pair? p) - (set! pairpks (cons pk pairpks))] + (cond [(pat:compound? p) + (let ([kind (pat:compound-kind p)]) + (hash-set! compound-ht + kind (cons pk (hash-ref compound-ht kind null))))] [(pat:datum? p) (let ([d (pat:datum-datum p)]) - (hash-set! ht d (cons pk (hash-ref ht d null))))] + (hash-set! datum-ht d (cons pk (hash-ref datum-ht d null))))] [(pat:literal? p) (let ([lit (pat:literal-literal p)]) (bound-identifier-mapping-put! @@ -522,9 +583,10 @@ (cons pk (bound-identifier-mapping-get lit-ht lit (lambda () null)))))]))) - (let ([datumpkss (hash-map ht make-datumpks)] - [litpkss (bound-identifier-mapping-map lit-ht make-literalpks)]) - (make cpks pairpks datumpkss litpkss))) + (let ([datumSGs (hash-map datum-ht make-datumSG)] + [literalSGs (bound-identifier-mapping-map lit-ht make-literalSG)] + [compoundSGs (hash-map compound-ht make-compoundSG)]) + (make descrimG datumSGs literalSGs compoundSGs))) (major-loop pks null)) @@ -565,13 +627,14 @@ (make-pk (cdr (pk-ps pk)) (pk-k pk))) (map shift-pk pks)) -;; shift-pks:pair : (listof PK) -> (listof PK) -(define (shift-pks:pair pks) +;; shift-pks:compound : (listof PK) -> (listof PK) +(define (shift-pks:compound pks) (define (shift-pk pk0) (match pk0 - [(struct pk ((cons (struct pat:pair (orig-stx attrs depth head tail)) rest-ps) + [(struct pk ((cons (struct pat:compound (orig-stx attrs depth kind patterns)) + rest-ps) k)) - (make-pk (list* head tail rest-ps) k)])) + (make-pk (append patterns rest-ps) k)])) (map shift-pk pks)) ;; wrap-pvars : (listof IAttr) stx -> stx diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss index 9464f7bb23..6de85b445f 100644 --- a/collects/stxclass/private/rep-data.ss +++ b/collects/stxclass/private/rep-data.ss @@ -14,8 +14,11 @@ (struct-out pat:id) (struct-out pat:datum) (struct-out pat:literal) - (struct-out pat:pair) + (struct-out pat:compound) (struct-out pat:gseq) + (struct-out pat:and) + (struct-out pat:orseq) + (struct-out kind) (struct-out head) (struct-out clause:when) (struct-out clause:with)) @@ -53,18 +56,24 @@ ;; (make-pat:pair Pattern Pattern) ;; (make-pat:seq Pattern Pattern) ;; (make-pat:gseq (listof Head) Pattern) +;; (make-pat:and string/#f (listof Pattern)) +;; (make-pat:compound Kind (listof Pattern)) ;; when = stx (listof IAttr) number (define-struct pattern (orig-stx attrs depth) #:transparent) (define-struct (pat:id pattern) (name stxclass args) #:transparent) (define-struct (pat:datum pattern) (datum) #:transparent) (define-struct (pat:literal pattern) (literal) #:transparent) -(define-struct (pat:pair pattern) (head tail) #:transparent) (define-struct (pat:gseq pattern) (heads tail) #:transparent) +(define-struct (pat:and pattern) (description subpatterns) #:transparent) +(define-struct (pat:orseq pattern) (heads) #:transparent) +(define-struct (pat:compound pattern) (kind patterns) #:transparent) + +;; A Kind is (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE))) +(define-struct kind (predicate selectors frontier-procs) #:transparent) ;; A Head is ;; (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f) -(define-struct head (orig-stx attrs depth ps min max as-list? occurs default) - #:transparent) +(define-struct head (orig-stx attrs depth ps min max as-list?) #:transparent) ;; A SideClause is one of ;; (make-clause:with pattern stx) @@ -84,7 +93,6 @@ (and (attr? a) (symbol? (attr-name a)))) - ;; Environments ;; DeclEnv maps [id => DeclEntry] diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index 00bdf50365..6eaf1a90a9 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -6,7 +6,8 @@ syntax/boundmap syntax/stx "../util.ss" - "rep-data.ss") + "rep-data.ss" + "codegen-data.ss") (provide/contract [parse-whole-pattern @@ -21,7 +22,10 @@ rhs?)] [check-literals-list (-> syntax? - (listof (list/c identifier? identifier?)))]) + (listof (list/c identifier? identifier?)))] + [pairK kind?] + [vectorK kind?] + [boxK kind?]) (define (atomic-datum? stx) (let ([datum (syntax-e stx)]) @@ -47,6 +51,40 @@ (and (identifier? stx) (free-identifier=? stx (quote-syntax ...*)))) +(define (and-kw? stx) + (and (identifier? stx) + (free-identifier=? stx (quote-syntax ~and)))) + +(define (orseq-kw? stx) + (and (identifier? stx) + (free-identifier=? stx (quote-syntax ~or)))) + +(define (reserved? stx) + (or (dots? stx) + (gdots? stx) + (and-kw? stx) + (orseq-kw? stx))) + +;; ---- Kinds ---- + +(define pairK + (make-kind #'pair? + (list (lambda (s d) #`(car #,d)) + (lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s))) + (list (lambda (fc x) (frontier:add-car fc x)) + (lambda (fc x) (frontier:add-cdr fc))))) + +(define vectorK + (make-kind #'vector? + (list (lambda (s d) + #`(datum->syntax #,s (vector->list #,d) #,s))) + (list (lambda (fc x) (frontier:add-unvector fc))))) + +(define boxK + (make-kind #'box? + (list (lambda (s d) #`(unbox #,d))) + (list (lambda (fc x) (frontier:add-unbox fc))))) + ;; --- ;; parse-rhs : stx(SyntaxClassRHS) boolean stx -> RHS @@ -146,12 +184,15 @@ pattern) ;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern -(define (parse-pattern stx decls depth) - (syntax-case stx () - [dots - (or (dots? #'dots) - (gdots? #'dots)) - (wrong-syntax stx "ellipses not allowed here")] +(define (parse-pattern stx decls depth + #:allow-orseq-pattern? [allow-orseq-pattern? #f]) + (syntax-case stx (~and ~or) + [gdots + (gdots? #'gdots) + (wrong-syntax stx "obsolete (...*) sequence syntax")] + [reserved + (reserved? #'reserved) + (wrong-syntax #'reserved "not allowed here")] [id (identifier? #'id) (match (declenv-lookup decls #'id) @@ -169,25 +210,46 @@ [datum (atomic-datum? #'datum) (make pat:datum stx null depth (syntax->datum #'datum))] - [(heads gdots . tail) - (gdots? #'gdots) - (let* ([heads (parse-heads #'heads decls depth)] - [tail (parse-pattern #'tail decls depth)] - [hattrs (append-attrs (for/list ([head heads]) (head-attrs head)))] - [tattrs (pattern-attrs tail)]) - (make pat:gseq stx (append-attrs (list hattrs tattrs)) depth heads tail))] + [(~and . rest) + (begin (unless (stx-list? #'rest) + (wrong-syntax stx "expected list of patterns")) + (parse-and-pattern stx decls depth))] + [(~or . heads) + (begin (unless (stx-list? #'heads) + (wrong-syntax stx "expected list of pattern sequences")) + (unless allow-orseq-pattern? + (wrong-syntax stx "or/sequence pattern not allowed here")) + (let* ([heads (parse-heads #'heads decls depth)] + [attrs + (append-attrs + (for/list ([head heads]) (head-attrs head)))]) + (make pat:orseq stx attrs depth heads)))] [(head dots . tail) (dots? #'dots) - (let* ([headp (parse-pattern #'head decls (add1 depth))] + (let* ([headp (parse-pattern #'head decls (add1 depth) + #:allow-orseq-pattern? #t)] + [heads + (if (pat:orseq? headp) + (pat:orseq-heads headp) + (list (pattern->head headp)))] [tail (parse-pattern #'tail decls depth)] - [head (pattern->head headp)] - [attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)))]) - (make pat:gseq stx attrs depth (list head) tail))] + [hattrs (pattern-attrs headp)] + [tattrs (pattern-attrs tail)]) + (make pat:gseq stx (append-attrs (list hattrs tattrs)) + depth heads tail))] [(a . b) (let ([pa (parse-pattern #'a decls depth)] [pb (parse-pattern #'b decls depth)]) - (let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))]) - (make pat:pair stx attrs depth pa pb)))])) + (define attrs + (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))) + (make pat:compound stx attrs depth pairK (list pa pb)) + #| (make pat:pair stx attrs depth pa pb) |#)] + [#(a ...) + (let ([lp (parse-pattern (syntax/loc stx (a ...)) decls depth)]) + (make pat:compound stx (pattern-attrs lp) depth vectorK (list lp)))] + [#&x + (let ([bp (parse-pattern #'x decls depth)]) + (make pat:compound stx (pattern-attrs bp) depth boxK (list bp)))])) (define (id-pattern-attrs name sc depth) (cond [(wildcard? name) null] @@ -201,16 +263,27 @@ [else (list (make attr name depth null))])) +;; parse-and-patttern : stxlist DeclEnv nat -> Pattern +(define (parse-and-pattern stx decls depth) + (define-values (chunks rest) + (chunk-kw-seq/no-dups (stx-cdr stx) and-pattern-directive-table)) + (define description + (cond [(assq '#:description chunks) => caddr] + [else #f])) + (define patterns + (for/list ([x (stx->list rest)]) + (parse-pattern x decls depth))) + (define attrs (append-attrs (map pattern-attrs patterns))) + (make pat:and stx attrs depth description patterns)) + (define (pattern->head p) (match p [(struct pattern (orig-stx iattrs depth)) - (make head orig-stx iattrs depth (list p) #f #f #t #f #f)])) + (make head orig-stx iattrs depth (list p) #f #f #t)])) (define head-directive-table (list (list '#:min check-nat/f) (list '#:max check-nat/f) - (list '#:occurs check-id) - (list '#:default values) (list '#:opt) (list '#:mand))) @@ -221,7 +294,6 @@ "empty head sequence not allowed")] [({p ...} . more) (let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)]) - (reject-duplicate-chunks chunks) ;; FIXME: needed? (cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks) (parse-heads rest decls enclosing-depth)))] [() @@ -232,11 +304,9 @@ [else #f]) "expected sequence of patterns or sequence directive")])) -(define (parse-head/chunks pstx decls enclosing-depth chunks) +(define (parse-head/chunks pstx decls depth chunks) (let* ([min-row (assq '#:min chunks)] [max-row (assq '#:max chunks)] - [occurs-row (assq '#:occurs chunks)] - [default-row (assq '#:default chunks)] [opt-row (assq '#:opt chunks)] [mand-row (assq '#:mand chunks)] [min-stx (and min-row (caddr min-row))] @@ -252,44 +322,25 @@ (when (and (or min-row max-row) (or opt-row mand-row)) (wrong-syntax (or min-stx max-stx) "min/max-constraints are incompatible with opt/mand directives")) - (when default-row - (unless opt-row - (wrong-syntax (cadr default-row) - "default only allowed for optional patterns"))) (parse-head/options pstx decls - enclosing-depth + depth (cond [opt-row 0] [mand-row 1] [else min]) (cond [opt-row 1] [mand-row 1] [else max]) - (not (or opt-row mand-row)) - (and occurs-row (caddr occurs-row)) - default-row))) + (not (or opt-row mand-row))))) -(define (parse-head/options pstx decls enclosing-depth - min max as-list? occurs-pvar default-row) - (let* ([depth (if as-list? (add1 enclosing-depth) enclosing-depth)] +(define (parse-head/options pstx decls depth min max as-list?) + (let* ([effective-depth (if as-list? depth (sub1 depth))] [heads - (for/list ([p (syntax->list pstx)]) - (parse-pattern p decls depth))] + (for/list ([p (stx->list pstx)]) + (parse-pattern p decls effective-depth))] [heads-attrs (append-attrs (map pattern-attrs heads))]) - (when default-row - (unless (and (= (length heads-attrs) 1) - (= enclosing-depth (attr-depth (car heads-attrs))) - (null? (attr-inner (car heads-attrs)))) - (wrong-syntax (cadr default-row) - "default only allowed for patterns with single simple pattern variable"))) - (let ([occurs-attrs - (if occurs-pvar - (list (make-attr occurs-pvar depth null)) - null)]) - (make head pstx - (append-attrs (list occurs-attrs heads-attrs)) - depth - heads - min max as-list? - occurs-pvar - (and default-row (caddr default-row)))))) + (make head pstx + heads-attrs + depth + heads + min max as-list?))) ;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id) ;; -> stx DeclEnv RemapEnv (listof SideClause) @@ -358,6 +409,13 @@ '()])) +;; check-lit-string : stx -> string +(define (check-lit-string stx) + (let ([x (syntax-e stx)]) + (unless (string? x) + (wrong-syntax stx "expected string literal")) + x)) + ;; check-attr-arity-list : stx -> (listof SAttr) (define (check-attr-arity-list stx) (unless (stx-list? stx) @@ -421,3 +479,7 @@ (list '#:rename check-id check-id) (list '#:with values values) (list '#:when values))) + +;; and-pattern-directive-table +(define and-pattern-directive-table + (list (list '#:description check-lit-string))) diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss index aea51fb425..df7c7cc61a 100644 --- a/collects/stxclass/private/runtime.ss +++ b/collects/stxclass/private/runtime.ss @@ -9,6 +9,8 @@ (for-syntax "../util/error.ss")) (provide pattern basic-syntax-class + ~and + ~or ...* with-enclosing-fail @@ -41,8 +43,9 @@ (define-keyword pattern) (define-keyword basic-syntax-class) +(define-keyword ~and) +(define-keyword ~or) (define-keyword ...*) -(define-keyword ...**) ;; Parameters & Syntax Parameters @@ -106,8 +109,8 @@ ;; Runtime: parsing failures/expectations ;; An Expectation is -;; (make-expc (listof scdyn) (listof expc) (listof atom) (listof id)) -(define-struct expc (stxclasses pairs? data literals) +;; (make-expc (listof scdyn) (listof string/#t) (listof atom) (listof id)) +(define-struct expc (stxclasses compound data literals) #:transparent) (define-struct scdyn (name desc failure) @@ -116,7 +119,7 @@ (define expectation/c (or/c expc?)) (define (make-stxclass-expc scdyn) - (make-expc (list scdyn) #f null null)) + (make-expc (list scdyn) null null null)) (begin-for-syntax (define certify (syntax-local-certifier)) @@ -131,18 +134,22 @@ (make-scdyn 'name (desc-var arg ...) (if (failed? #,result-var) #,result-var #f))))))) - (define (expectation-of-constants pairs? data literals) + (define (expectation-of-constants pairs? data literals description) (with-syntax ([(datum ...) data] [(literal ...) literals] - [pairs? pairs?]) + [pairs? pairs?] + [description + (if pairs? + (list (or description #t)) + null)]) (certify - #'(make-expc null 'pairs? (list 'datum ...) + #'(make-expc null 'description (list 'datum ...) (list (quote-syntax literal) ...))))) (define (expectation-of/message msg) (with-syntax ([msg msg]) (certify - #'(make-expc '() #f '((msg)) '()))))) + #'(make-expc '() '() '((msg)) '()))))) (define-syntax (try stx) (syntax-case stx () @@ -174,7 +181,7 @@ (define (merge-expectations e1 e2) (make-expc (union (expc-stxclasses e1) (expc-stxclasses e2)) - (or (expc-pairs? e1) (expc-pairs? e2)) + (union (expc-compound e1) (expc-compound e2)) (union (expc-data e1) (expc-data e2)) (union (expc-literals e1) (expc-literals e2)))) @@ -183,9 +190,9 @@ (define (expectation-of-null? e) (match e - [(struct expc (scs pairs? data literals)) + [(struct expc (scs compound data literals)) (and (null? scs) - (not pairs?) + (null? compound) (null? literals) (and (pair? data) (null? (cdr data))) (equal? (car data) '()))] @@ -193,16 +200,18 @@ (define (expectation->string e) (match e - [(struct expc (_ #t _ _)) - #f] - [(struct expc (stxclasses pairs? data literals)) - (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))] - [s2 (and (pair? data) (string-of-data data))] - [s3 (and (pair? literals) (string-of-literals literals))] - [s4 (and pairs? string-of-pairs?)]) - (join-sep (filter string? (list s1 s2 s3 s4)) - ";" - "or"))])) + [(struct expc (stxclasses compound data literals)) + (cond [(null? compound) + (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))] + [s2 (and (pair? data) (string-of-data data))] + [s3 (and (pair? literals) (string-of-literals literals))]) + (join-sep (filter string? (list s1 s2 s3)) + ";" + "or"))] + [(andmap string? compound) + (join-sep compound ";" "or")] + [else + #f])])) (define (string-of-stxclasses scdyns) (comma-list (map string-of-stxclass scdyns))) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index a74c93fce4..7e5d702c9f 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -24,6 +24,8 @@ pattern basic-syntax-class + ~and + ~or ...* attribute diff --git a/collects/stxclass/scribblings/parsing-syntax.scrbl b/collects/stxclass/scribblings/parsing-syntax.scrbl index 8e9ae9b039..93d253320a 100644 --- a/collects/stxclass/scribblings/parsing-syntax.scrbl +++ b/collects/stxclass/scribblings/parsing-syntax.scrbl @@ -55,15 +55,21 @@ procedure accepts a single argument, which should be a syntax object. The grammar of patterns accepted by @scheme[syntax-parse] and @scheme[syntax-parser] follows: -@schemegrammar*[#:literals (_ ...*) +@schemegrammar*[#:literals (_ ~or ~and) [syntax-pattern pvar-id pvar-id:syntax-class-id literal-id atomic-datum (syntax-pattern . syntax-pattern) - (syntax-pattern #,ellipses . syntax-pattern) - ((head ...+) ...* . syntax-pattern)] + (ellipsis-head-pattern #,ellipses . syntax-pattern) + (~and maybe-description syntax-pattern ...)] + [ellipsis-head-pattern + (~or head ...+) + syntax-pattern] + [maybe-description + (code:line) + (code:line #:description string)] [pvar-id _ id]] @@ -116,17 +122,8 @@ Matches a syntax pair whose head matches the first pattern and whose tail matches the second. } -@;{ -@specsubform[(syntax-splice-pattern . syntax-pattern)]{ -Matches a syntax object which consists of any sequence of syntax -objects matching the splice pattern followed by a tail matching the -given tail pattern. - -} -} - -@specsubform[(syntax-pattern #,ellipses . syntax-pattern)]{ +@specsubform[(ellipsis-head-pattern #,ellipses . syntax-pattern)]{ Matches a sequence of the first pattern ending in a tail matching the second pattern. @@ -135,23 +132,21 @@ That is, the sequence pattern matches either the second pattern (which need not be a list) or a pair whose head matches the first pattern and whose tail recursively matches the whole sequence pattern. -} -@specsubform/subs[#:literals (...*) - ((head ...+) ...* . syntax-pattern) +The head pattern can be either an ordinary pattern or an +or/sequence-pattern: + +@specsubform/subs[#:literals (~or) + (~or head ...+) ([head (code:line (syntax-pattern ...+) head-directive ...)] [head-directive (code:line #:min min-reps) (code:line #:max max-reps) - (code:line #:mand) - #| (code:line #:opt) - (code:line #:occurs occurs-pvar-id) - (code:line #:default default-form) - |#])]{ + (code:line #:mand)])]{ -Matches a sequence of any combination of the heads ending in a tail -matching the final pattern. The match is subject to constraints -specified on the heads. +If the head is an or/sequence-pattern (introduced by @scheme[~or]), +then the whole sequence pattern matches any combination of the head +sequences followed by a tail matching the final pattern. @specsubform[(code:line #:min min-reps)]{ @@ -175,27 +170,16 @@ in the preceding head are not bound at a higher ellipsis nesting depth. } -@;{ -@specsubform[#:opt]{ - -(Probably a bad idea.) - } } -} -@;{ -The variants of @scheme[_syntax-splice-pattern] follow: +@specsubform/subs[#:literals (~and) + (~and maybe-description syntax-pattern ...) + ([maybe-description + (code:line) + (code:line #:description string)])]{ -@specsubform[pvar-id:syntax-splice-class-id]{ +Matches any syntax that matches all of the included patterns. -Matches a sequence of syntax objects described by -@scheme[_syntax-splice-class-id]. - -The name @scheme[_pvar-id] is bound, but not allowed within -expressions or @scheme[syntax] templates (since it does not refer to a -particular syntax object). Only the prefixed attributes of the splice -class are usable. -} } Both @scheme[syntax-parse] and @scheme[syntax-parser] support @@ -241,10 +225,19 @@ backtracks as described above; otherwise, it continues. } -@defidform[...*]{ + +@defidform[~and]{ Keyword recognized by @scheme[syntax-parse] etc as notation for -generalized sequences. It may not be used as an expression. +and-patterns. + +} + +@defidform[~or]{ + +Keyword recognized by @scheme[syntax-parse] etc as notation for +or/sequence-patterns (within sequences). It may not be used as an +expression. } diff --git a/collects/tests/stxclass/stxclass.ss b/collects/tests/stxclass/stxclass.ss index d11e383b08..1ebeb878c2 100644 --- a/collects/tests/stxclass/stxclass.ss +++ b/collects/tests/stxclass/stxclass.ss @@ -118,37 +118,37 @@ (check-equal? (syntax->datum #'(t.a ...)) '(1 4 6))) (test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8)) (check-equal? (syntax->datum #'(t.b ...)) '(2 5 7))) - (test-patterns ({{x:id v:nat} {s:str}} ...*) #'(x 1 y 2 "whee" x 3) + (test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3) (check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3))) (check-equal? (stx->datum #'(s ...)) '("whee"))) - (test-patterns ({{x:id v:nat} {s:str}} ...*) #'(x 1 y 2 "whee" x 3) + (test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3) (check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3))) (check-equal? (stx->datum #'(s ...)) '("whee"))) - (test-patterns ({{1} #:min 1 #:max 1 - {2} #:min 1 #:max 1 - {3} #:min 1 #:max 1} ...*) + (test-patterns ({~or {1} #:min 1 #:max 1 + {2} #:min 1 #:max 1 + {3} #:min 1 #:max 1} ...) #'(1 2 3) 'ok) - (test-patterns ({{a:id} {b:nat} {c:str}} ...*) #'("one" 2 three) + (test-patterns ({~or {a:id} {b:nat} {c:str}} ...) #'("one" 2 three) (check-equal? (stx->datum #'(a ...)) '(three)) (check-equal? (stx->datum #'(b ...)) '(2)) (check-equal? (stx->datum #'(c ...)) '("one"))) - (test-patterns ({{1} #:min 1 #:max 1 - {2} #:min 1 #:max 1 - {3} #:min 1 #:max 1 - {x} #:min 1 #:max 1 - {y} #:min 1 #:max 1 - {w} #:min 1 #:max 1} ...*) + (test-patterns ({~or {1} #:min 1 #:max 1 + {2} #:min 1 #:max 1 + {3} #:min 1 #:max 1 + {x} #:min 1 #:max 1 + {y} #:min 1 #:max 1 + {w} #:min 1 #:max 1} ...) #'(1 2 3 x y z) (for ([s (syntax->list #'(x ... y ... w ...))]) (check-pred identifier? s)) (check-equal? (sort (map symbol->string (stx->datum #'(x ... y ... w ...))) stringdatum #'(x ...)) '(x y z))) ))) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 526d91843e..135384af86 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -251,7 +251,7 @@ (pattern (case-lambda f:fun-ty/one ...) #:with t (make-Function (syntax->datum #'(f.arr ...)))) - (pattern (t:Class (pos-args:type ...) ([fname:id fty:type ((rest:boolean) #:opt) ...*] ...) ([mname:id mty:type] ...)) + (pattern (t:Class (pos-args:type ...) ([fname:id fty:type (~or (rest:boolean) #:opt) ...] ...) ([mname:id mty:type] ...)) #:with t (make-Class (syntax->datum #'(pos-args.t ...)) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index d34ce7dd0d..3988110b43 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -66,7 +66,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx [(_ lib [nm:opt-rename ty] ...) #'(begin (require/typed nm ty lib) ...)] - [(_ nm:opt-rename ty lib ([#:struct-maker parent] #:opt) ...*) + [(_ nm:opt-rename ty lib (~or [#:struct-maker parent] #:opt) ...) (with-syntax ([cnt* (generate-temporary #'nm.nm)] [sm (if #'parent #'(#:struct-maker parent) @@ -87,7 +87,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax-class name-exists-kw (pattern #:name-exists)) (syntax-parse stx - [(_ ty:id pred:id lib ([ne:name-exists-kw] #:opt) ...*) + [(_ ty:id pred:id lib (~or [ne:name-exists-kw] #:opt) ...) (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) (quasisyntax/loc stx (begin diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss index 3a33b0f34d..35de27f4cc 100644 --- a/collects/typed-scheme/private/type-abbrev.ss +++ b/collects/typed-scheme/private/type-abbrev.ss @@ -82,7 +82,7 @@ (define-syntax (->key stx) (syntax-parse stx - [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) + [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) #'(make-Function (list (make-arr* (list ty ...) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index 2430ee4af9..fa696eb829 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -7,9 +7,9 @@ (define-syntax (defintern stx) (syntax-parse stx - [(_ name+args make-name key ([#:extra-arg e:expr]) ...*) + [(_ name+args make-name key (~or [#:extra-arg e:expr]) ...) #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)] - [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*) + [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...) #'(define *name (let ([table (make-ht)]) (lambda (arg ...) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 2d2ecc7d98..1d97957d70 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -70,11 +70,11 @@ (define (mk par ht-stx) (lambda (stx) (syntax-parse stx - [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt - [[#:intern intern?:expr]] #:opt - [[#:frees . frees:frees-pat]] #:opt - [[#:fold-rhs fold-rhs:fold-pat]] #:opt - [no-provide?:no-provide-kw] #:opt) ...*) + [(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt + [[#:intern intern?:expr]] #:opt + [[#:frees . frees:frees-pat]] #:opt + [[#:fold-rhs fold-rhs:fold-pat]] #:opt + [no-provide?:no-provide-kw] #:opt) ...) (with-syntax* ([ex (mk-id #'nm #'nm ":")] [kw-stx (string->keyword (symbol->string #'nm.datum))] From 112811258b6c1ca2487fc72aaf1d13e97364cbb8 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 18 Feb 2009 04:44:38 +0000 Subject: [PATCH 035/142] stxclass: undo r13714, because it messes up non-stx attributes svn: r13723 --- collects/stxclass/private/codegen.ss | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index 5bb8d59758..7d9d458f03 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -113,9 +113,8 @@ (let ([inner (wrap-pvars (pattern-attrs p) (convert-sides rest main-var body-expr))]) - (with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))] - [with-rhs (syntax/loc e with-rhs)]) - #`(let ([x (datum->syntax #f #,e (quote-syntax with-rhs))] + (with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))]) + #`(let ([x #,e] [fail-k enclosing-fail]) #,(parse:pks (list #'x) (list (done-frontier #'x)) From cc29c603c0b842b473a3762166b7bc20cc469e3c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 18 Feb 2009 08:50:18 +0000 Subject: [PATCH 036/142] Welcome to a new PLT day. svn: r13724 --- 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 bb3f8b2aac..a92a2b2f17 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "17feb2009") +#lang scheme/base (provide stamp) (define stamp "18feb2009") From cf856a33bfc39f6c50ec850cb06f67a3a39178d1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 18 Feb 2009 13:11:08 +0000 Subject: [PATCH 037/142] forward keywords svn: r13725 --- collects/scheme/private/contract.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 7fb1f48aa1..c728ad2eab 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -148,7 +148,7 @@ improve method arity mismatch contract violation error messages? (define-syntax (define-struct/contract stx) (syntax-case stx () - [(_ name ([field ctc] ...)) + [(_ name ([field ctc] ...) kwds ...) (let ([fields (syntax->list #'(field ...))]) (unless (identifier? #'name) (raise-syntax-error 'define-struct/contract @@ -176,6 +176,7 @@ improve method arity mismatch contract violation error messages? (with-contract #:type struct name (name struct:name id/ctc ...) (define-struct name (field ...) + kwds ... #:guard (λ (field ... struct-name) (unless (eq? 'name struct-name) (error (format "Cannot create subtype ~a of contracted struct ~a" From 172b0828e849e03309b57b5d99263b4c3832b899 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 18 Feb 2009 13:48:57 +0000 Subject: [PATCH 038/142] split out the input section into chunks, added contracts to the structs (and fixed a bunch of test cases that were kind of lax about the struct values) svn: r13726 --- .../games/chat-noir/chat-noir-literate.ss | 1292 ++++++++--------- 1 file changed, 646 insertions(+), 646 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 773d13c508..fc731c121d 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -3,7 +3,7 @@ @;{ The command to build this: -mzc chat-noir-doc.ss && scribble ++xref-in setup/xref load-collections-xref --htmls chat-noir-doc.ss +mzc chat-noir-doc.ss && rm -rf chat-noir-doc && scribble ++xref-in setup/xref load-collections-xref --htmls chat-noir-doc.ss } @@ -56,8 +56,9 @@ and some code that builds an initial world and starts the game. + - ] + ] Each section also comes with a series of test cases that are collected into the @chunkref[] chunk at the end of the program. @@ -68,7 +69,8 @@ Each section also comes with a series of test cases that are collected into the graph-tests> - ] + + ] Each test case uses either @scheme[test], a simple form that accepts two arguments and compares them with @scheme[equal?], or @scheme[test/set] @@ -85,15 +87,24 @@ The main data structure for Chat Noir is @tt{world}. It comes with a few functio construct empty worlds and test cases for them. @chunk[ - ] + ] @chunk[ - ] + ] The main structure definition is the @scheme[world] struct. -@chunk[ -(define-struct world (board cat state size mouse-posn h-down?) +@chunk[ +(define-struct/contract world ([board (listof cell?)] + [cat posn?] + [state (or/c 'playing + 'cat-won + 'cat-lost)] + [size (and/c natural-number/c + odd? + (>=/c 3))] + [mouse-posn (or/c #f posn?)] + [h-down? boolean?]) #:transparent) ] @@ -128,22 +139,23 @@ It consists of a structure with six fields: A @scheme[cell] is a structure with two fields: -@chunk[ - (define-struct cell (p blocked?) #:transparent)] +@chunk[ + (define-struct/contract cell ([p posn?] + [blocked? boolean?]) + #:transparent)] -The first field contains a @scheme[posn] struct. The coordinates of -the posn indicate a position on the hexagonal grid. +The coordinates of +the @scheme[posn] in the first field +indicate a position on the hexagonal grid. This program reprsents the hexagon grid as a series of rows that are offset from each other by 1/2 the size of the each cell. The @tt{y} field of the @scheme[posn] refers to the row of the cell, and the @tt{x} coordinate the position in the row. This means that, for example, @scheme[(make-posn 1 0)] is centered above @scheme[(make-posn 1 0)] -and @scheme[(make-posn 1 1)]. (See @scheme[cell-center-x] and -@scheme[cell-center-y] below for the conversion of those positions to -screen coordinates.) +and @scheme[(make-posn 1 1)]. -The @tt{blocked?} field is a boolean indicating if the cell has been +The boolean in the @tt{blocked?} field indicates if the cell has been clicked on, thus blocking the cat from stepping there. The @scheme[empty-board] function builds a list of @scheme[cell]s @@ -255,6 +267,55 @@ cats initial position as the center spot on the board. false false))] +@chunk[ + + ;; add-n-random-blocked-cells : number (listof cell) number -> (listof cell) + (define (add-n-random-blocked-cells n all-cells board-size) + (cond + [(zero? n) all-cells] + [else + (local [(define unblocked-cells + (filter (lambda (x) + (let ([cat-cell? (and (= (posn-x (cell-p x)) + (quotient board-size 2)) + (= (posn-y (cell-p x)) + (quotient board-size 2)))]) + + (and (not (cell-blocked? x)) + (not cat-cell?)))) + all-cells)) + (define to-block (list-ref unblocked-cells + (random (length unblocked-cells))))] + (add-n-random-blocked-cells + (sub1 n) + (block-cell (cell-p to-block) all-cells) + board-size))])) + + ;; block-cell : posn board -> board + (define (block-cell to-block board) + (map (lambda (c) (if (equal? to-block (cell-p c)) + (make-cell to-block true) + c)) + board))] + +@chunk[ + (test (block-cell (make-posn 1 1) + (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 2) false))) + (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 2 2) false))) + + (test (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) + true)) + 10) + (list (make-cell (make-posn 0 0) true))) + (test (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) + false)) + 10) + (list (make-cell (make-posn 0 0) true)))] + @section{Breadth-first Search} The cat's move decision is based on a breadth-first search of a graph. @@ -281,16 +342,18 @@ The breadth-first function constructs a @scheme[distance-map], which is a list of @scheme[dist-cell] structs: @chunk[ -(define-struct dist-cell (p n) #:transparent)] + (define-struct/contract dist-cell ([p (or/c 'boundary posn?)] + [n natural-number/c]) + #:transparent)] Each @tt{p} field in the @scheme[dist-cell] is a position on the board -and the @tt{n} field is a natural number or @scheme['∞], indicating +and the @tt{n} field is a natural number, indicating the distance of the shortest path from the node to some fixed point on the board. The function @scheme[lookup-in-table] returns the distance from the fixed point to the given posn, returning @scheme['∞] if the posn is not in the -table or if it is mapped to @scheme['∞] in the table. +table. @chunk[ (define/contract (lookup-in-table t p) @@ -400,7 +463,7 @@ it calls the @scheme[bfs] function and then transforms the result, using @scheme[hash-map], into a list of @scheme[cell]s. -@section{Board to Graph Functions} +@section{Board to Graph} As far as the @scheme[build-bfs-table] function goes, all of the information specific to Chat Noir is @@ -832,12 +895,12 @@ except it has a smile. (make-world (list (make-cell (make-posn 0 1) false)) (make-posn 0 1) 'playing - 2 + 3 (make-posn 0 0) false)) (overlay (board->image (list (make-cell (make-posn 0 1) false)) - 2 + 3 (lambda (x) true) false) (move-pinhole thinking-cat @@ -849,12 +912,12 @@ except it has a smile. (make-world (list (make-cell (make-posn 0 1) false)) (make-posn 0 1) 'cat-won - 2 + 3 false false)) (overlay (board->image (list (make-cell (make-posn 0 1) false)) - 2 + 3 (lambda (x) true) false) (move-pinhole happy-cat @@ -866,12 +929,12 @@ except it has a smile. (make-world (list (make-cell (make-posn 0 1) false)) (make-posn 0 1) 'cat-lost - 2 + 3 false false)) (overlay (board->image (list (make-cell (make-posn 0 1) false)) - 2 + 3 (lambda (x) true) false) (move-pinhole mad-cat @@ -1182,6 +1245,524 @@ except it has a smile. circle-radius)] + +@section{Handling Input} + +@chunk[ + + + + + + + + + ] + +@chunk[ + + + + + + + + + ] + +@chunk[ + (define (clack world x y evt) + (cond + [(equal? evt 'button-up) + (cond + [(and (equal? 'playing (world-state world)) + (point-in-a-circle? (world-board world) x y)) + (move-cat + (update-world-posn + (make-world (add-obstacle (world-board world) x y) + (world-cat world) + (world-state world) + (world-size world) + (world-mouse-posn world) + (world-h-down? world)) + (make-posn x y)))] + [else (update-world-posn world (make-posn x y))])] + [(equal? evt 'button-down) + world] + [(equal? evt 'drag) world] + [(equal? evt 'move) + (update-world-posn world (make-posn x y))] + [(equal? evt 'enter) + (update-world-posn world (make-posn x y))] + [(equal? evt 'leave) + (update-world-posn world false)]))] + +@chunk[ + (test (clack (make-world '() (make-posn 0 0) 'playing 3 false false) + 1 1 'button-down) + (make-world '() (make-posn 0 0) 'playing 3 false false)) + (test (clack (make-world '() (make-posn 0 0) 'playing 3 false false) + 1 1 'drag) + (make-world '() (make-posn 0 0) 'playing 3 false false)) + (test (clack (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) + 'playing + 3 + false + false) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) + 'move) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) + 'playing + 3 + (make-posn 0 0) + false)) + (test (clack (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) + 'playing + 3 + false + false) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) + 'enter) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) + 'playing + 3 + (make-posn 0 0) + false)) + (test (clack (make-world '() (make-posn 0 0) + 'playing 3 (make-posn 0 0) false) + 1 1 'leave) + (make-world '() (make-posn 0 0) 'playing 3 false false)) + + (test (clack (make-world '() (make-posn 0 0) + 'playing 3 (make-posn 0 0) false) + 10 + 10 + 'button-down) + (make-world '() (make-posn 0 0) 'playing 3 (make-posn 0 0) false)) + + (test (clack (make-world (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 1 1) false)) + (make-posn 1 1) + 'playing + 3 + (make-posn 0 0) + false) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) + 'button-up) + (make-world (list (make-cell (make-posn 0 0) true) + (make-cell (make-posn 1 1) false)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn 0 0) + false)) + + + (test (clack (make-world '() (make-posn 0 0) + 'cat-lost 3 (make-posn 0 0) false) + 10 + 10 + 'button-up) + (make-world '() (make-posn 0 0) + 'cat-lost 3 (make-posn 0 0) false)) + (test (clack + (make-world + (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'playing + 3 + false + false) + (cell-center-x (make-posn 1 0)) + (cell-center-y (make-posn 1 0)) + 'button-up) + (make-world + (list (make-cell (make-posn 1 0) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn 1 0) + false)) + + (test (clack + (make-world + (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'playing + 3 + false + false) + (cell-center-x (make-posn 1 0)) + (cell-center-y (make-posn 1 0)) + 'button-up) + (make-world + (list (make-cell (make-posn 1 0) true) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 2 0) + 'cat-won + 3 + (make-posn 1 0) + false))] + +@chunk[ + ;; update-world-posn/playing : world posn-or-false -> world + (define (update-world-posn w p) + (cond + [(equal? (world-state w) 'playing) + (cond + [(posn? p) + (local [(define mouse-spot + (circle-at-point (world-board w) + (posn-x p) + (posn-y p)))] + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + (cond + [(equal? mouse-spot (world-cat w)) + false] + [else + mouse-spot]) + (world-h-down? w)))] + [else + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + false + (world-h-down? w))])] + [else w]))] + +@chunk[ + + (test (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'playing 3 false false) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'playing 3 (make-posn 0 0) false)) + + (test (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 0) 'playing 3 false false) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 0) 'playing 3 false false)) + + (test (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'playing 3 (make-posn 0 0) false) + (make-posn 0 0)) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'playing 3 false false)) + (test (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'cat-won 3 false false) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'cat-won 3 false false)) + (test (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'cat-lost 3 false false) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'cat-lost 3 false false))] + +@chunk[ + ;; move-cat : world -> world + (define (move-cat world) + (local [(define cat-position (world-cat world)) + (define table (build-bfs-table world 'boundary)) + (define neighbors (adjacent cat-position)) + (define next-cat-positions + (find-best-positions neighbors + (map (lambda (p) (lookup-in-table table p)) + neighbors))) + (define next-cat-position + (cond + [(boolean? next-cat-positions) false] + [else + (list-ref next-cat-positions + (random (length next-cat-positions)))]))] + (make-world (world-board world) + (cond + [(boolean? next-cat-position) + cat-position] + [else next-cat-position]) + (cond + [(boolean? next-cat-position) + 'cat-lost] + [(on-boundary? next-cat-position (world-size world)) + 'cat-won] + [else 'playing]) + (world-size world) + (world-mouse-posn world) + (world-h-down? world))))] + +@chunk[ + (test + (move-cat + (make-world (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 3 0) false) + (make-cell (make-posn 4 0) false) + + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 3 1) false) + (make-cell (make-posn 4 1) false) + + (make-cell (make-posn 0 2) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) false) + (make-cell (make-posn 3 2) true) + (make-cell (make-posn 4 2) false) + + (make-cell (make-posn 0 3) false) + (make-cell (make-posn 1 3) true) + (make-cell (make-posn 2 3) false) + (make-cell (make-posn 3 3) false) + (make-cell (make-posn 4 3) false) + + (make-cell (make-posn 1 4) false) + (make-cell (make-posn 2 4) false) + (make-cell (make-posn 3 4) false) + (make-cell (make-posn 4 4) false)) + (make-posn 2 2) + 'playing + 5 + (make-posn 0 0) + false)) + (make-world (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 3 0) false) + (make-cell (make-posn 4 0) false) + + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 3 1) false) + (make-cell (make-posn 4 1) false) + + (make-cell (make-posn 0 2) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) false) + (make-cell (make-posn 3 2) true) + (make-cell (make-posn 4 2) false) + + (make-cell (make-posn 0 3) false) + (make-cell (make-posn 1 3) true) + (make-cell (make-posn 2 3) false) + (make-cell (make-posn 3 3) false) + (make-cell (make-posn 4 3) false) + + (make-cell (make-posn 1 4) false) + (make-cell (make-posn 2 4) false) + (make-cell (make-posn 3 4) false) + (make-cell (make-posn 4 4) false)) + (make-posn 2 3) + 'playing + 5 + (make-posn 0 0) + false))] + +@chunk[ + ;; find-best-positions : (nelistof posn) (nelistof number or '∞) + ;; -> (nelistof posn) or false + (define (find-best-positions posns scores) + (local [(define best-score (foldl (lambda (x sofar) + (if (<=/f x sofar) + x + sofar)) + (first scores) + (rest scores)))] + (cond + [(symbol? best-score) false] + [else + (map + second + (filter (lambda (x) (equal? (first x) best-score)) + (map list scores posns)))])))] + +@chunk[ + (test (find-best-positions (list (make-posn 0 0)) (list 1)) + (list (make-posn 0 0))) + (test (find-best-positions (list (make-posn 0 0)) (list '∞)) + false) + (test (find-best-positions (list (make-posn 0 0) + (make-posn 1 1)) + (list 1 2)) + (list (make-posn 0 0))) + (test (find-best-positions (list (make-posn 0 0) + (make-posn 1 1)) + (list 1 1)) + (list (make-posn 0 0) + (make-posn 1 1))) + (test (find-best-positions (list (make-posn 0 0) + (make-posn 1 1)) + (list '∞ 2)) + (list (make-posn 1 1))) + (test (find-best-positions (list (make-posn 0 0) + (make-posn 1 1)) + (list '∞ '∞)) + false)] + +@chunk[ + ;; <=/f : (number or '∞) (number or '∞) -> boolean + (define (<=/f a b) + (cond + [(equal? b '∞) true] + [(equal? a '∞) false] + [else (<= a b)]))] + +@chunk[ + (test (<=/f 1 2) true) + (test (<=/f 2 1) false) + (test (<=/f '∞ 1) false) + (test (<=/f 1 '∞) true) + (test (<=/f '∞ '∞) true)] + +@chunk[ + ;; add-obstacle : board number number -> board + (define (add-obstacle board x y) + (cond + [(empty? board) board] + [else + (local [(define cell (first board)) + (define cx (cell-center-x (cell-p cell))) + (define cy (cell-center-y (cell-p cell)))] + (cond + [(and (<= (- cx circle-radius) x (+ cx circle-radius)) + (<= (- cy circle-radius) y (+ cy circle-radius))) + (cons (make-cell (cell-p cell) true) + (rest board))] + [else + (cons cell (add-obstacle (rest board) x y))]))]))] + +@chunk[ + (test (add-obstacle (list (make-cell (make-posn 0 0) false)) + circle-spacing circle-spacing) + (list (make-cell (make-posn 0 0) true))) + (test (add-obstacle (list (make-cell (make-posn 0 0) false)) 100 100) + (list (make-cell (make-posn 0 0) false))) + (test (add-obstacle (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + circle-spacing circle-spacing) + (list (make-cell (make-posn 0 0) true) + (make-cell (make-posn 0 1) false)))] + +@chunk[ + ;; circle-at-point : board number number -> posn-or-false + ;; returns the posn corresponding to cell where the x,y coordinates are + (define (circle-at-point board x y) + (cond + [(empty? board) false] + [else + (cond + [(point-in-this-circle? (cell-p (first board)) x y) + (cell-p (first board))] + [else + (circle-at-point (rest board) x y)])])) + + (define (point-in-a-circle? board x y) + (posn? (circle-at-point board x y)))] + +@chunk[ + (test (circle-at-point empty 0 0) false) + (test (circle-at-point (list (make-cell (make-posn 0 0) false)) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + (make-posn 0 0)) + (test (circle-at-point (list (make-cell (make-posn 0 0) false)) + 0 0) + false) + + + (test (point-in-a-circle? empty 0 0) false) + (test (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + true) + (test (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) + 0 0) + false)] + +@chunk[ + ;; point-in-this-circle? : posn number number -> boolean + (define (point-in-this-circle? p x y) + (local [(define center (+ (cell-center-x p) + (* (sqrt -1) (cell-center-y p)))) + (define p2 (+ x (* (sqrt -1) y)))] + (<= (magnitude (- center p2)) circle-radius)))] + +@chunk[ + (test (point-in-this-circle? (make-posn 0 0) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + true) + (test (point-in-this-circle? (make-posn 0 0) 0 0) + false)] + +@chunk[ + ;; change : world key-event -> world + (define (change w ke) + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + (world-mouse-posn w) + (key=? ke #\h)))] + +@chunk[ + (test (change (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) false) + #\h) + (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) true)) + (test (change (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) true) + 'release) + (make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) false))] + + +] + @section{Tests} @chunk[ @@ -1189,25 +1770,29 @@ except it has a smile. (define-syntax (test stx) (syntax-case stx () [(_ actual expected) - (with-syntax ([line (syntax-line stx)]) + (with-syntax ([line (syntax-line stx)] + [pos (syntax-position stx)]) #'(test/proc (λ () actual) (λ () expected) equal? - line))])) + line + 'actual))])) (define-syntax (test/set stx) (syntax-case stx () [(_ actual expected) - (with-syntax ([line (syntax-line stx)]) + (with-syntax ([line (syntax-line stx)] + [pos (syntax-position stx)]) #'(test/proc (λ () actual) (λ () expected) (λ (x y) (same-sets? x y)) - line))])) + line + 'actual))])) (define test-count 0) (define test-procs '()) -(define (test/proc actual-thunk expected-thunk cmp line) +(define (test/proc actual-thunk expected-thunk cmp line sexp) (set! test-procs (cons (λ () @@ -1215,9 +1800,11 @@ except it has a smile. (let ([actual (actual-thunk)] [expected (expected-thunk)]) (unless (cmp actual expected) - (error 'check-expect "test ~a on line ~a failed:\n ~s\n ~s\n" + (error 'check-expect "test #~a~a\n ~s\n ~s\n" test-count - line + (if line + (format " on line ~a failed:" line) + (format " failed: ~s" sexp)) actual expected)))) test-procs))) @@ -1540,618 +2127,31 @@ except it has a smile. (test (+/f 1 '∞) '∞) (test (+/f 1 2) 3)] -@section{Everything Else} +@section{Run, program, run} - -@chunk[ - -#;'() - - - -; -; -; -; -; -; ;;;;; ;;;; ;;;;;; -; ;;; ;;;;; ;;;; -; ;;; ;;; -; ;;;;;; ;;; ; ;;;;;; ;;; ;;;; -; ;;; ;;;; ;;; ;;;;; ;;; ;;;; ;;; ;;;;;; -; ;;; ;;;;; ;;; ;;; ;;; ;;;;; ;;; ;;;;; -; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;;; -; ;;; ;; ;;; ;;; ;;;;;; -; ;;; ; ;;; ;;;; ;;; ; ;; ;; -; ;;; ; ;;;; ;;;;;;;;;; ; ;;;;; ;;;; -; ;;;; ;;;; -; -; -; - - -(define (clack world x y evt) - (cond - [(equal? evt 'button-up) - (cond - [(and (equal? 'playing (world-state world)) - (point-in-a-circle? (world-board world) x y)) - (move-cat - (update-world-posn - (make-world (add-obstacle (world-board world) x y) - (world-cat world) - (world-state world) - (world-size world) - (world-mouse-posn world) - (world-h-down? world)) - (make-posn x y)))] - [else (update-world-posn world (make-posn x y))])] - [(equal? evt 'button-down) - world] - [(equal? evt 'drag) world] - [(equal? evt 'move) - (update-world-posn world (make-posn x y))] - [(equal? evt 'enter) - (update-world-posn world (make-posn x y))] - [(equal? evt 'leave) - (update-world-posn world false)])) - -(test (clack (make-world '() (make-posn 0 0) 'playing 1 false false) - 1 1 'button-down) - (make-world '() (make-posn 0 0) 'playing 1 false false)) -(test (clack (make-world '() (make-posn 0 0) 'playing 1 false false) - 1 1 'drag) - (make-world '() (make-posn 0 0) 'playing 1 false false)) -(test (clack (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 1 - false - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'move) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 1 - (make-posn 0 0) - false)) -(test (clack (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 1 - false - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'enter) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 1 - (make-posn 0 0) - false)) -(test (clack (make-world '() (make-posn 0 0) - 'playing 1 (make-posn 0 0) false) - 1 1 'leave) - (make-world '() (make-posn 0 0) 'playing 1 false false)) - -(test (clack (make-world '() (make-posn 0 0) - 'playing 1 (make-posn 0 0) false) - 10 - 10 - 'button-down) - (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false)) - -(test (clack (make-world (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'button-up) - (make-world (list (make-cell (make-posn 0 0) true) - (make-cell (make-posn 1 1) false)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 0 0) - false)) - - -(test (clack (make-world '() (make-posn 0 0) - 'cat-lost 1 (make-posn 0 0) false) - 10 - 10 - 'button-up) - (make-world '() (make-posn 0 0) - 'cat-lost 1 (make-posn 0 0) false)) -(test (clack - (make-world - (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'playing - 3 - false - false) - (cell-center-x (make-posn 1 0)) - (cell-center-y (make-posn 1 0)) - 'button-up) - (make-world - (list (make-cell (make-posn 1 0) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 1 0) - false)) - -(test (clack - (make-world - (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'playing - 3 - false - false) - (cell-center-x (make-posn 1 0)) - (cell-center-y (make-posn 1 0)) - 'button-up) - (make-world - (list (make-cell (make-posn 1 0) true) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 2 0) - 'cat-won - 3 - (make-posn 1 0) - false)) - -;; update-world-posn/playing : world posn-or-false -> world -(define (update-world-posn w p) - (cond - [(equal? (world-state w) 'playing) - (cond - [(posn? p) - (local [(define mouse-spot - (circle-at-point (world-board w) - (posn-x p) - (posn-y p)))] - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - (cond - [(equal? mouse-spot (world-cat w)) - false] - [else - mouse-spot]) - (world-h-down? w)))] - [else - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - false - (world-h-down? w))])] - [else w])) - -(test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'playing 1 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'playing 1 (make-posn 0 0) false)) - -(test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 0) 'playing 1 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 0) 'playing 1 false false)) - -(test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'playing 1 (make-posn 0 0) false) - (make-posn 0 0)) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'playing 1 false false)) -(test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'cat-won 1 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'cat-won 1 false false)) -(test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'cat-lost 1 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'cat-lost 1 false false)) - -;; move-cat : world -> world -(define (move-cat world) - (local [(define cat-position (world-cat world)) - (define table (build-bfs-table world 'boundary)) - (define neighbors (adjacent cat-position)) - (define next-cat-positions - (find-best-positions neighbors - (map (lambda (p) (lookup-in-table table p)) - neighbors))) - (define next-cat-position - (cond - [(boolean? next-cat-positions) false] - [else - (list-ref next-cat-positions - (random (length next-cat-positions)))]))] - (make-world (world-board world) - (cond - [(boolean? next-cat-position) - cat-position] - [else next-cat-position]) - (cond - [(boolean? next-cat-position) - 'cat-lost] - [(on-boundary? next-cat-position (world-size world)) - 'cat-won] - [else 'playing]) - (world-size world) - (world-mouse-posn world) - (world-h-down? world)))) - - -(test - (move-cat - (make-world (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 3 0) false) - (make-cell (make-posn 4 0) false) - - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 3 1) false) - (make-cell (make-posn 4 1) false) - - (make-cell (make-posn 0 2) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) false) - (make-cell (make-posn 3 2) true) - (make-cell (make-posn 4 2) false) - - (make-cell (make-posn 0 3) false) - (make-cell (make-posn 1 3) true) - (make-cell (make-posn 2 3) false) - (make-cell (make-posn 3 3) false) - (make-cell (make-posn 4 3) false) - - (make-cell (make-posn 1 4) false) - (make-cell (make-posn 2 4) false) - (make-cell (make-posn 3 4) false) - (make-cell (make-posn 4 4) false)) - (make-posn 2 2) - 'playing - 5 - (make-posn 0 0) - false)) - (make-world (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 3 0) false) - (make-cell (make-posn 4 0) false) - - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 3 1) false) - (make-cell (make-posn 4 1) false) - - (make-cell (make-posn 0 2) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) false) - (make-cell (make-posn 3 2) true) - (make-cell (make-posn 4 2) false) - - (make-cell (make-posn 0 3) false) - (make-cell (make-posn 1 3) true) - (make-cell (make-posn 2 3) false) - (make-cell (make-posn 3 3) false) - (make-cell (make-posn 4 3) false) - - (make-cell (make-posn 1 4) false) - (make-cell (make-posn 2 4) false) - (make-cell (make-posn 3 4) false) - (make-cell (make-posn 4 4) false)) - (make-posn 2 3) - 'playing - 5 - (make-posn 0 0) - false)) - -;; find-best-positions : (nelistof posn) (nelistof number or '∞) -;; -> (nelistof posn) or false -(define (find-best-positions posns scores) - (local [(define best-score (foldl (lambda (x sofar) - (if (<=/f x sofar) - x - sofar)) - (first scores) - (rest scores)))] - (cond - [(symbol? best-score) false] - [else - (map - second - (filter (lambda (x) (equal? (first x) best-score)) - (map list scores posns)))]))) -(test (find-best-positions (list (make-posn 0 0)) (list 1)) - (list (make-posn 0 0))) -(test (find-best-positions (list (make-posn 0 0)) (list '∞)) - false) -(test (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list 1 2)) - (list (make-posn 0 0))) -(test (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list 1 1)) - (list (make-posn 0 0) - (make-posn 1 1))) -(test (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list '∞ 2)) - (list (make-posn 1 1))) -(test (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list '∞ '∞)) - false) - -;; <=/f : (number or '∞) (number or '∞) -> boolean -(define (<=/f a b) - (cond - [(equal? b '∞) true] - [(equal? a '∞) false] - [else (<= a b)])) - -(test (<=/f 1 2) true) -(test (<=/f 2 1) false) -(test (<=/f '∞ 1) false) -(test (<=/f 1 '∞) true) -(test (<=/f '∞ '∞) true) - -;; add-obstacle : board number number -> board -(define (add-obstacle board x y) - (cond - [(empty? board) board] - [else - (local [(define cell (first board)) - (define cx (cell-center-x (cell-p cell))) - (define cy (cell-center-y (cell-p cell)))] - (cond - [(and (<= (- cx circle-radius) x (+ cx circle-radius)) - (<= (- cy circle-radius) y (+ cy circle-radius))) - (cons (make-cell (cell-p cell) true) - (rest board))] - [else - (cons cell (add-obstacle (rest board) x y))]))])) - -(test (add-obstacle (list (make-cell (make-posn 0 0) false)) - circle-spacing circle-spacing) - (list (make-cell (make-posn 0 0) true))) -(test (add-obstacle (list (make-cell (make-posn 0 0) false)) 100 100) - (list (make-cell (make-posn 0 0) false))) -(test (add-obstacle (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - circle-spacing circle-spacing) - (list (make-cell (make-posn 0 0) true) - (make-cell (make-posn 0 1) false))) - -;; circle-at-point : board number number -> posn-or-false -;; returns the posn corresponding to cell where the x,y coordinates are -(define (circle-at-point board x y) - (cond - [(empty? board) false] - [else - (cond - [(point-in-this-circle? (cell-p (first board)) x y) - (cell-p (first board))] - [else - (circle-at-point (rest board) x y)])])) -(test (circle-at-point empty 0 0) false) -(test (circle-at-point (list (make-cell (make-posn 0 0) false)) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - (make-posn 0 0)) -(test (circle-at-point (list (make-cell (make-posn 0 0) false)) - 0 0) - false) - - -;; point-in-a-circle? : board number number -> boolean -(define (point-in-a-circle? board x y) - (posn? (circle-at-point board x y))) -(test (point-in-a-circle? empty 0 0) false) -(test (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - true) -(test (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) - 0 0) - false) - -;; point-in-this-circle? : posn number number -> boolean -(define (point-in-this-circle? p x y) - (local [(define center (+ (cell-center-x p) - (* (sqrt -1) (cell-center-y p)))) - (define p2 (+ x (* (sqrt -1) y)))] - (<= (magnitude (- center p2)) circle-radius))) - -(test (point-in-this-circle? (make-posn 0 0) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - true) -(test (point-in-this-circle? (make-posn 0 0) 0 0) - false) - -;; change : world key-event -> world -(define (change w ke) - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - (world-mouse-posn w) - (key=? ke #\h))) - -(test (change (make-world '() (make-posn 1 1) - 'playing 1 (make-posn 0 0) false) - #\h) - (make-world '() (make-posn 1 1) - 'playing 1 (make-posn 0 0) true)) -(test (change (make-world '() (make-posn 1 1) - 'playing 1 (make-posn 0 0) true) - 'release) - (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false)) - - - - -; -; -; -; -; -; ;;;; ;;;; ;;;; ;;;; ;;;;; -; ;;;;; ;;;;; ;;; ;;;;; ;;; -; ;;; ; ;;; -; ;;;;;; ;; ; ;;;;;;;;; ; ;;;; ;; ;;; -; ;;;;; ;;; ;;;; ;;;;; ;;; ;;;;;;; ;;;;;;;;; ;;; -; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; -; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;; ;;;; ;; -; ;;;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;;;;;;;; ;;; -; ;;;;;;;;;; ;;; ;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;; -; ;;;; ;;;;; ;;;;; -; ;;; -; -; -; -; -; -; -; -; ;;;;; ;; -; ;;;; ;;;; -; ;;; ;;; -; ;;; ;;; ;;;;; ;;;; ;; ; ;;;; ;;; ;;; -; ;;;;;;;; ;;;;;;; ;;;;;;;;;;;;;;; ;;;; ;;;;;;;; -; ;;;;;;;; ;;;;;;;; ;;;;;;;;;; ;;; ;;;;;;;;;;;;;; -; ;;; ;; ;; ; ;;; ;;; ;;; ;;;; ;;; ;;; -; ;;; ;; ; ;; ;; ;;;; ;;; ;; ;;;; -; ;;;;;;; ;;;;;;;; ;;;;;;;;;; ;;; ;;;;;;;; -; ;;;;;;; ;;;;;; ;;;;;;;;;;;;;;;;;; ;;;;;;;;; -; ;;;; ;;;;; -; -; -; - -;; add-n-random-blocked-cells : number (listof cell) number -> (listof cell) -(define (add-n-random-blocked-cells n all-cells board-size) - (cond - [(zero? n) all-cells] - [else - (local [(define unblocked-cells - (filter (lambda (x) - (let ([cat-cell? (and (= (posn-x (cell-p x)) - (quotient board-size 2)) - (= (posn-y (cell-p x)) - (quotient board-size 2)))]) - - (and (not (cell-blocked? x)) - (not cat-cell?)))) - all-cells)) - (define to-block (list-ref unblocked-cells - (random (length unblocked-cells))))] - (add-n-random-blocked-cells - (sub1 n) - (block-cell (cell-p to-block) all-cells) - board-size))])) - -;; block-cell : posn board -> board -(define (block-cell to-block board) - (map (lambda (c) (if (equal? to-block (cell-p c)) - (make-cell to-block true) - c)) - board)) -(test (block-cell (make-posn 1 1) - (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 2) false))) - (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 2) false))) - -(test (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) - true)) - 10) - (list (make-cell (make-posn 0 0) true))) -(test (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) - false)) - 10) - (list (make-cell (make-posn 0 0) true))) - -(define dummy - (local - [(define board-size 11) - (define initial-board - (add-n-random-blocked-cells - 6 - (empty-board board-size) - board-size)) - (define initial-world - (make-world initial-board - (make-posn (quotient board-size 2) - (quotient board-size 2)) - 'playing - board-size - false - false))] - - (and - (big-bang (world-width board-size) - (world-height board-size) - 1 - initial-world) - (on-redraw render-world) - (on-key-event change) - (on-mouse-event clack)))) - -(run-tests) -] +@chunk[ + (run-tests) + + (let* ([board-size 11] + [initial-board + (add-n-random-blocked-cells + 6 + (empty-board board-size) + board-size)] + [initial-world + (make-world initial-board + (make-posn (quotient board-size 2) + (quotient board-size 2)) + 'playing + board-size + false + false)]) + + (big-bang (world-width board-size) + (world-height board-size) + 1 + initial-world) + (on-redraw render-world) + (on-key-event change) + (on-mouse-event clack) + (void))] From 7e1ea98876ee61833b92f53497a131b74b3405f5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 18 Feb 2009 21:14:50 +0000 Subject: [PATCH 039/142] Pull back Robby's allowance of all struct options just a bit, plus handle the ones we do allow natively. svn: r13727 --- collects/scheme/private/contract.ss | 248 ++++++++++++++---- .../scribblings/reference/contracts.scrbl | 13 +- collects/tests/mzscheme/contract-test.ss | 58 ++++ 3 files changed, 272 insertions(+), 47 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index c728ad2eab..0b122dccae 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -126,27 +126,154 @@ improve method arity mismatch contract violation error messages? (syntax/loc define-stx (define/contract name+arg-list contract #:freevars () body0 body ...))])) -(define-for-syntax (ds/c-build-struct-names name fields) - (let ([name-str (symbol->string (syntax-e name))]) - (list* (datum->syntax - name - (string->symbol - (string-append "struct:" name-str))) - (datum->syntax - name - (string->symbol - (string-append "make-" name-str))) - (datum->syntax - name - (string->symbol - (string-append name-str "?"))) - (for/list ([field-str (map (compose symbol->string syntax-e) fields)]) +(define-syntax (define-struct/contract stx) + (define-struct field-info (stx ctc [mutable? #:mutable] auto?)) + (define-struct s-info (auto-value-stx transparent? def-stxs? def-vals?)) + + (define (build-struct-names name field-infos) + (let ([name-str (symbol->string (syntax-e name))]) + (list* (datum->syntax + name + (string->symbol + (string-append "struct:" name-str))) (datum->syntax name (string->symbol - (string-append name-str "-" field-str))))))) + (string-append "make-" name-str))) + (datum->syntax + name + (string->symbol + (string-append name-str "?"))) + (apply append + (for/list ([finfo field-infos]) + (let ([field-str (symbol->string (syntax-e (field-info-stx finfo)))]) + (cons (datum->syntax + name + (string->symbol + (string-append name-str "-" field-str))) + (if (field-info-mutable? finfo) + (list (datum->syntax + name + (string->symbol + (string-append "set-" name-str "-" field-str "!")))) + null)))))))) + + (define (build-contracts stx pred field-infos) + (list* (quasisyntax/loc stx + (-> #,@(map field-info-ctc + (filter (λ (f) + (not (field-info-auto? f))) + field-infos)) any/c)) + (syntax/loc stx any/c) + (apply append + (for/list ([finfo field-infos]) + (let ([field-ctc (field-info-ctc finfo)]) + (cons (quasisyntax/loc stx + (-> #,pred #,field-ctc)) + (if (field-info-mutable? finfo) + (list + (quasisyntax/loc stx + (-> #,pred #,field-ctc void?))) + null))))))) -(define-syntax (define-struct/contract stx) + (define (check-field f ctc) + (let ([p-list (syntax->list f)]) + (if p-list + (begin + (when (null? p-list) + (raise-syntax-error 'define-struct/contract + "expected struct field" + f)) + (unless (identifier? (car p-list)) + (raise-syntax-error 'define-struct/contract + "expected identifier" + f)) + (let loop ([rest (cdr p-list)] + [mutable? #f] + [auto? #f]) + (if (null? rest) + (make-field-info (car p-list) ctc mutable? auto?) + (let ([elem (syntax-e (car rest))]) + (if (keyword? elem) + (cond + [(eq? elem '#:mutable) + (begin (when mutable? + (raise-syntax-error 'define-struct/contract + "redundant #:mutable" + (car rest))) + (loop (cdr rest) #t auto?))] + [(eq? elem '#:auto) + (begin (when auto? + (raise-syntax-error 'define-struct/contract + "redundant #:mutable" + (car rest))) + (loop (cdr rest) mutable? #t))] + [else (raise-syntax-error 'define-struct/contract + "expected #:mutable or #:auto" + (car rest))]) + (raise-syntax-error 'define-struct/contract + "expected #:mutable or #:auto" + (car rest))))))) + (if (identifier? f) + (make-field-info f ctc #f #f) + (raise-syntax-error 'define-struct/contract + "expected struct field" + f))))) + (define (check-kwds kwd-list field-infos) + (let loop ([kwds kwd-list] + [auto-value-stx #f] + [mutable? #f] + [transparent? #f] + [def-stxs? #t] + [def-vals? #t]) + (if (null? kwds) + (make-s-info auto-value-stx transparent? def-stxs? def-vals?) + (let ([kwd (syntax-e (car kwds))]) + (when (not (keyword? kwd)) + (raise-syntax-error 'define-struct/contract + "expected a keyword" + (car kwds))) + (cond + [(eq? kwd '#:auto-value) + (when (null? (cdr kwd-list)) + (raise-syntax-error 'define-struct/contract + "expected a following expression" + (car kwds))) + (loop (cddr kwd-list) (cadr kwd-list) + transparent? mutable? def-stxs? def-vals?)] + [(eq? kwd '#:mutable) + (when mutable? + (raise-syntax-error 'define-struct/contract + "redundant #:mutable" + (car kwds))) + (for ([finfo field-infos]) + (set-field-info-mutable?! finfo #t)) + (loop (cdr kwd-list) auto-value-stx + transparent? #t def-stxs? def-vals?)] + [(eq? kwd '#:transparent) + (when transparent? + (raise-syntax-error 'define-struct/contract + "redundant #:transparent" + (car kwds))) + (loop (cdr kwd-list) auto-value-stx + #t mutable? def-stxs? def-vals?)] + [(eq? kwd '#:omit-define-syntaxes) + (when (not def-stxs?) + (raise-syntax-error 'define-struct/contract + "redundant #:omit-define-syntaxes" + (car kwds))) + (loop (cdr kwd-list) auto-value-stx + transparent? mutable? #f def-vals?)] + [(eq? kwd '#:omit-define-values) + (when (not def-vals?) + (raise-syntax-error 'define-struct/contract + "redundant #:omit-define-values" + (car kwds))) + (loop (cdr kwd-list) auto-value-stx + transparent? mutable? def-stxs? #f)] + [else (raise-syntax-error 'define-struct/contract + "unexpected keyword" + (car kwds))]))))) (syntax-case stx () [(_ name ([field ctc] ...) kwds ...) (let ([fields (syntax->list #'(field ...))]) @@ -154,34 +281,67 @@ improve method arity mismatch contract violation error messages? (raise-syntax-error 'define-struct/contract "expected identifier for struct name" #'name)) - (for-each (λ (f) - (unless (identifier? f) - (raise-syntax-error 'define-struct/contract - "expected identifier for field name" - f))) - fields) - (let* ([names (ds/c-build-struct-names #'name fields)] + (let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))] + [sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)] + [names (build-struct-names #'name field-infos)] [pred (caddr names)] - [ctcs (list* (syntax/loc stx - (-> ctc ... any/c)) - (syntax/loc stx any/c) - (let ([field-ctc (quasisyntax/loc stx - (-> #,pred any/c))]) - (build-list - (length fields) - (λ (_) field-ctc))))]) - (with-syntax ([struct:name (car names)] - [(id/ctc ...) (map list (cdr names) ctcs)]) - (syntax/loc stx - (with-contract #:type struct name - (name struct:name id/ctc ...) - (define-struct name (field ...) - kwds ... - #:guard (λ (field ... struct-name) - (unless (eq? 'name struct-name) - (error (format "Cannot create subtype ~a of contracted struct ~a" - struct-name 'name))) - (values field ...))))))))] + [ctcs (build-contracts stx pred field-infos)]) + (let-values ([(non-auto-fields auto-fields) + (let loop ([fields field-infos] + [nautos null] + [autos null]) + (if (null? fields) + (values (reverse nautos) + (reverse autos)) + (if (field-info-auto? (car fields)) + (loop (cdr fields) + nautos + (cons (car fields) autos)) + (if (null? autos) + (loop (cdr fields) + (cons (car fields) nautos) + autos) + (raise-syntax-error 'define-struct/contract + "non-auto field after auto fields" + (field-info-stx (car fields)))))))]) + (with-syntax ([ctc-bindings + (let ([val-bindings (if (s-info-def-vals? sinfo) + (map list (cdr names) ctcs) + null)]) + (if (s-info-def-stxs? sinfo) + (cons (car names) val-bindings) + val-bindings))] + [orig stx] + [(auto-check ...) + (let* ([av-stx (if (s-info-auto-value-stx sinfo) + (s-info-auto-value-stx sinfo) + #'#f)] + [av-id (datum->syntax av-stx + (string->symbol + (string-append (symbol->string (syntax-e #'name)) + ":auto-value")) + av-stx)]) + (for/list ([finfo auto-fields]) + #`(let ([#,av-id #,av-stx]) + (-contract #,(field-info-ctc finfo) + #,av-id + '(struct name) + 'cant-happen + #,(id->contract-src-info av-id)))))] + [(non-auto-name ...) + (map field-info-stx non-auto-fields)]) + (syntax/loc stx + (begin + (define-values () (begin auto-check ... (values))) + (with-contract #:type struct name + ctc-bindings + (define-struct/derived orig name (field ...) + kwds ... + #:guard (λ (non-auto-name ... struct-name) + (unless (eq? 'name struct-name) + (error (format "Cannot create subtype ~a of contracted struct ~a" + struct-name 'name))) + (values non-auto-name ...))))))))))] [(_ name . bad-fields) (identifier? #'name) (raise-syntax-error 'define-struct/contract diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 7b02e605c6..388617e93a 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -720,9 +720,16 @@ inside the @scheme[body] will be protected with contracts that blame the context of the @scheme[define/contract] form for the positive positions and the @scheme[define/contract] form for the negative ones.} -@defform*[[(define-struct/contract struct-id ([field-id contract-expr] ...))]]{ -Works like @scheme[define-struct], except that the arguments to the constructor -and accessors are protected by contracts.} +@defform*[[(define-struct/contract struct-id ([field contract-expr] ...) + struct-option ...)]]{ +Works like @scheme[define-struct], except that the arguments to the constructor, +accessors, and mutators are protected by contracts. For the definitions of +@scheme[field] and @scheme[struct-option], see @scheme[define-struct]. + +The @scheme[define-struct/contract] form only allows a subset of the +@scheme[struct-option] keywords: @scheme[#:mutable], @scheme[#:transparent], +@scheme[#:auto-value], @scheme[#:omit-define-syntaxes], and +@scheme[#:omit-define-values].} @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index fde5500ced..917e07c2ae 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2529,6 +2529,64 @@ (foo-y 1)) "top-level") + (test/spec-passed + 'define-struct/contract6 + '(let () + (define-struct/contract foo ([x number?] [y number?]) #:mutable) + (set-foo-y! (make-foo 1 2) 3) + (set-foo-x! (make-foo 1 2) 3))) + + (test/spec-failed + 'define-struct/contract7 + '(let () + (define-struct/contract foo ([x number?] [y number?]) #:mutable) + (set-foo-y! (make-foo 1 2) #f)) + "top-level") + + (test/spec-passed + 'define-struct/contract8 + '(let () + (define-struct/contract foo ([(x #:mutable) number?] [y number?])) + (set-foo-x! (make-foo 1 2) 4))) + + (test/spec-failed + 'define-struct/contract9 + '(let () + (define-struct/contract foo ([(x #:mutable) number?] [y number?])) + (set-foo-x! (make-foo 1 2) #f)) + "top-level") + + (test/spec-failed + 'define-struct/contract10 + '(let () + (define-struct/contract foo ([x number?] [(y #:auto) number?])) + (make-foo 1)) + "(struct foo)") + + (test/spec-passed + 'define-struct/contract11 + '(let () + (define-struct/contract foo ([x number?] [(y #:auto) number?]) #:auto-value 3) + (make-foo 1))) + + (test/spec-passed + 'define-struct/contract12 + '(let () + (define-struct/contract foo ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3) + (set-foo-y! (make-foo 1) 3))) + + (test/spec-failed + 'define-struct/contract13 + '(let () + (define-struct/contract foo ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3) + (set-foo-y! (make-foo 1) #t)) + "top-level") + + (test/spec-passed + 'define-struct/contract14 + '(let () + (define-struct/contract foo ([x number?] [y number?]) #:transparent) + 1)) ; ; ; From ada4a7aeaedd2ab56255d3bc0b33cc2f76bdaa99 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Feb 2009 21:29:58 +0000 Subject: [PATCH 040/142] allow negative years in a 'date' structure svn: r13728 --- collects/scribblings/reference/time.scrbl | 2 +- src/mzscheme/src/struct.c | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/reference/time.scrbl b/collects/scribblings/reference/time.scrbl index ac484daaa8..ca72c8637b 100644 --- a/collects/scribblings/reference/time.scrbl +++ b/collects/scribblings/reference/time.scrbl @@ -33,7 +33,7 @@ portability is needed.} [hour (integer-in 0 23)] [day (integer-in 1 31)] [month (integer-in 1 12)] - [year exact-nonnegative-integer?] + [year exact-integer?] [week-day (integer-in 0 6)] [year-day (integer-in 0 365)] [dst? boolean?] diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 1f0472e9a7..8c0c3d0753 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -3694,9 +3694,8 @@ static Scheme_Object *check_date_fields(int argc, Scheme_Object **argv) if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 1) || (SCHEME_INT_VAL(a) > 12)) scheme_wrong_field_type(argv[10], "integer in [1, 12]", a); a = argv[5]; - if ((!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0)) - && (!SCHEME_BIGNUMP(a) || !SCHEME_BIGPOS(a))) - scheme_wrong_field_type(argv[10], "nonnegative exact integer", a); + if (!SCHEME_INTP(a) && !SCHEME_BIGNUMP(a)) + scheme_wrong_field_type(argv[10], "exact integer", a); a = argv[6]; if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0) || (SCHEME_INT_VAL(a) > 6)) scheme_wrong_field_type(argv[10], "integer in [0, 6]", a); From 15475b6c7a01d6919ab95f14078e07c467b77c5b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Feb 2009 22:18:20 +0000 Subject: [PATCH 041/142] fix 'namespace-undefined-variable!' to use constantness checking svn: r13729 --- src/mzscheme/src/env.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 9617d026e6..33d2512a6e 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -3990,6 +3990,10 @@ namespace_undefine_variable(int argc, Scheme_Object *argv[]) if (scheme_lookup_global(argv[0], env)) { bucket = scheme_global_bucket(argv[0], env); + scheme_set_global_bucket("namespace-undefine-variable!", + bucket, + NULL, + 0); bucket->val = NULL; } else { scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[0], From f083e6b50d9291a5b9de111e64bede52febe83b1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 18 Feb 2009 22:50:48 +0000 Subject: [PATCH 042/142] fixed an off-by-one error (flooring negative numbers should go towards zero whe moving pinholes to be consistent with overlay/xy) svn: r13730 --- collects/htdp/image.ss | 43 ++++++++++++++++----------- collects/tests/mzscheme/htdp-image.ss | 13 ++++++++ 2 files changed, 38 insertions(+), 18 deletions(-) diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss index 4c58afff08..0b51021648 100644 --- a/collects/htdp/image.ss +++ b/collects/htdp/image.ss @@ -77,6 +77,13 @@ plt/collects/tests/mzscheme/htdp-image.ss ;; ---------------------------------------- +(define (floor0 n) + (cond + [(< n 0) (- (floor (- n)))] + [else (floor n)])) + +;; ---------------------------------------- + (define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v)) (define (check-coordinate name val arg-posn) (check name finite-real? val "finite real number" arg-posn)) @@ -169,8 +176,8 @@ plt/collects/tests/mzscheme/htdp-image.ss (width w) (height h) (argb (send i get-argb/no-compute)) - (px (+ px dx)) - (py (+ py dy)))))) + (px (+ px (floor0 dx))) + (py (+ py (floor0 dy))))))) (define (put-pinhole raw-i px py) (check-image 'put-pinhole raw-i "first") @@ -184,8 +191,8 @@ plt/collects/tests/mzscheme/htdp-image.ss (width w) (height h) (argb (send i get-argb/no-compute)) - (px (floor px)) - (py (floor py)))))) + (px (floor0 px)) + (py (floor0 py)))))) (define (overlay a b . cs) (check-image 'overlay a "first") @@ -209,8 +216,8 @@ plt/collects/tests/mzscheme/htdp-image.ss (check-image 'overlay/xy b "fourth") (real-overlay/xy 'overlay/xy a - (floor (if (exact? dx) dx (inexact->exact dx))) - (floor (if (exact? dy) dy (inexact->exact dy))) + (floor0 (if (exact? dx) dx (inexact->exact dx))) + (floor0 (if (exact? dy) dy (inexact->exact dy))) b)) (define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b) @@ -256,10 +263,10 @@ plt/collects/tests/mzscheme/htdp-image.ss (check-size/0 'shrink in-up "third") (check-size/0 'shrink in-right "fourth") (check-size/0 'shrink in-down "fifth") - (let ([left (inexact->exact (floor in-left))] - [up (inexact->exact (floor in-up))] - [right (inexact->exact (floor in-right))] - [down (inexact->exact (floor in-down))] + (let ([left (inexact->exact (floor0 in-left))] + [up (inexact->exact (floor0 in-up))] + [right (inexact->exact (floor0 in-right))] + [down (inexact->exact (floor0 in-down))] [img (coerce-to-cache-image-snip raw-img)]) (let-values ([(i-px i-py) (send img get-pinhole)] [(i-width i-height) (send img get-size)]) @@ -289,16 +296,16 @@ plt/collects/tests/mzscheme/htdp-image.ss (check-image 'shrink-tl raw-img "first") (check-size 'shrink-tl in-x "second") (check-size 'shrink-tl in-y "third") - (let ([x (inexact->exact (floor in-x))] - [y (inexact->exact (floor in-y))]) + (let ([x (inexact->exact (floor0 in-x))] + [y (inexact->exact (floor0 in-y))]) (put-pinhole (shrink (put-pinhole raw-img 0 0) 0 0 (- x 1) (- y 1)) (/ x 2) (/ y 2)))) (define (shrink-tr raw-img in-x in-y) (check-image 'shrink-tr raw-img "first") (check-size 'shrink-tr in-x "second") (check-size 'shrink-tr in-y "third") - (let ([x (inexact->exact (floor in-x))] - [y (inexact->exact (floor in-y))]) + (let ([x (inexact->exact (floor0 in-x))] + [y (inexact->exact (floor0 in-y))]) (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) 0) (- x 1) 0 0 (- y 1)) (/ x 2) (/ y 2)))) @@ -307,8 +314,8 @@ plt/collects/tests/mzscheme/htdp-image.ss (check-image 'shrink-bl raw-img "first") (check-size 'shrink-bl in-x "second") (check-size 'shrink-bl in-y "third") - (let ([x (inexact->exact (floor in-x))] - [y (inexact->exact (floor in-y))]) + (let ([x (inexact->exact (floor0 in-x))] + [y (inexact->exact (floor0 in-y))]) (put-pinhole (shrink (put-pinhole raw-img 0 (- (image-height raw-img) 1)) 0 (- y 1) (- x 1) 0) (/ x 2) (/ y 2)))) @@ -317,8 +324,8 @@ plt/collects/tests/mzscheme/htdp-image.ss (check-image 'shrink-br raw-img "first") (check-size 'shrink-br in-x "second") (check-size 'shrink-br in-y "third") - (let ([x (inexact->exact (floor in-x))] - [y (inexact->exact (floor in-y))]) + (let ([x (inexact->exact (floor0 in-x))] + [y (inexact->exact (floor0 in-y))]) (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) (- (image-height raw-img) 1)) (- x 1) (- y 1) diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss index 2a0bd8db84..40a9e72886 100644 --- a/collects/tests/mzscheme/htdp-image.ss +++ b/collects/tests/mzscheme/htdp-image.ss @@ -1058,6 +1058,19 @@ (image->color-list (add-line (rectangle 10 10 'solid 'blue) 0.1 #e.2 2.1 2.2 'red))) +(test #t + 'flooring/rounding-is-consistent + (image=? (overlay (rectangle 10 10 'solid 'black) + (move-pinhole + (rectangle 5 5 'solid 'red) + (- (+ 5 1/10)) + (- (+ 5 1/10)))) + (overlay/xy (rectangle 10 10 'solid 'black) + (+ 5 1/10) + (+ 5 1/10) + (rectangle 5 5 'solid 'red)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; The tests beginning with "bs-" ensure From 128d5287f7791c69634519438af43c0b29c35f1c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Feb 2009 23:14:18 +0000 Subject: [PATCH 043/142] add and use at-exp meta-language svn: r13731 --- collects/at-exp/lang/reader.ss | 61 ++++++++++++++++++++++ collects/file/gif.ss | 4 +- collects/framework/main.ss | 3 +- collects/scribblings/scribble/reader.scrbl | 30 +++++++++-- 4 files changed, 90 insertions(+), 8 deletions(-) create mode 100644 collects/at-exp/lang/reader.ss diff --git a/collects/at-exp/lang/reader.ss b/collects/at-exp/lang/reader.ss new file mode 100644 index 0000000000..71ea0b2453 --- /dev/null +++ b/collects/at-exp/lang/reader.ss @@ -0,0 +1,61 @@ +#lang scheme/base + +(require syntax/readerr + (only-in scribble/reader make-at-readtable)) + +(provide (rename-out [at-read read] + [at-read-syntax read-syntax]) + get-info) + +(define (at-get in export-sym src line col pos mk-fail-thunk) + (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(\\s|$)" in)] + [bad (lambda (str eof?) + ((if eof? + raise-read-eof-error + raise-read-error) + (format "bad language path following at-exp~a~a" + (if str ": " "") + (or str "")) + src line col pos + (let-values ([(line col pos2) (port-next-location in)]) + (and pos pos2 (- pos2 pos)))))]) + (if (or (not spec) + (equal? (cadr spec) "")) + (bad #f (eof-object? (peek-byte in))) + (let ([parsed-spec + (let ([s (string->symbol + (string-append (bytes->string/latin-1 (cadr spec)) + "/lang/reader"))]) + (if (module-path? s) + s + #f))]) + (if parsed-spec + (begin + ((current-reader-guard) parsed-spec) + (dynamic-require parsed-spec export-sym (mk-fail-thunk spec))) + (bad (cadr spec) #f)))))) + +(define (get-info in mod line col pos) + (at-get in 'get-info (object-name in) line col pos + (lambda (spec) (lambda () (lambda (tag) #f))))) + +(define at-readtable (make-at-readtable)) + +(define (at-read-fn in read-sym args src mod line col pos) + (let ([r (at-get in read-sym src #|mod|# line col pos + (lambda (spec) + (lambda () + (error 'at "cannot find reader for `#lang at ~a'" spec))))]) + (parameterize ([current-readtable at-readtable]) + (if (and (procedure? r) + (procedure-arity-includes? r (+ 5 (length args)))) + (apply r (append args + (list in mod line col pos))) + (apply r (append args (list in))))))) + +(define (at-read inp mod line col pos) + (at-read-fn inp 'read null (object-name inp) mod line col pos)) + +(define (at-read-syntax src inp mod line col pos) + (at-read-fn inp 'read-syntax (list src) src mod line col pos)) + diff --git a/collects/file/gif.ss b/collects/file/gif.ss index 50750f5ed4..bc612b517a 100644 --- a/collects/file/gif.ss +++ b/collects/file/gif.ss @@ -14,8 +14,8 @@ *****************************************************************************/ |# -#reader scribble/reader -#lang scheme/base +#lang at-exp scheme/base + (require scheme/contract scribble/srcdoc (prefix-in octree: file/private/octree-quantize)) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 13817b08a7..f3617ea598 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -1,5 +1,4 @@ -#reader scribble/reader -#lang scheme/gui +#lang at-exp scheme/gui (require mred/mred-unit mred/mred-sig diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl index 449b1d971b..97ece3341e 100644 --- a/collects/scribblings/scribble/reader.scrbl +++ b/collects/scribblings/scribble/reader.scrbl @@ -23,13 +23,16 @@ You can use the reader via MzScheme's @schemefont{#reader} form: #reader scribble/reader @foo{This is free-form text!} }|] +or use the @scheme[at-exp] meta-language as described in +@secref["at-exp-lang"]. + Note that the Scribble reader reads @"@"-forms as S-expressions. This means that it is up to you to give meanings for these expressions in the usual way: use Scheme functions, define your functions, or require functions. For example, typing the above into MzScheme is likely -going to produce a ``reference to undefined identifier'' error --- you -can use @scheme[string-append] instead, or you can define @scheme[foo] -as a function (with variable arity). +going to produce a ``reference to undefined identifier'' error, unless +@scheme[foo] is defined. You can use @scheme[string-append] instead, +or you can define @scheme[foo] as a function (with variable arity). A common use of the Scribble @"@"-reader is when using Scribble as a documentation system for producing manuals. In this case, the manual @@ -37,7 +40,7 @@ text is likely to start with @schememod[scribble/doc] -which installs the @"@" reader starting in ``text mode'', wraps the +which installs the @"@" reader starting in ``text mode,'' wraps the file content afterward into a MzScheme module where many useful Scheme and documentation related functions are available, and parses the body into a document using @schememodname[scribble/decode]. See @@ -833,6 +836,25 @@ is an example of this. }) ] +@;-------------------------------------------------------------------- +@section[#:tag "at-exp-lang"]{Adding @"@"-expressions to a Language} + +@defmodulelang[at-exp]{The @schememodname[at-exp] language installs +@"@"-reader support in the readtable, and then chains to the reader of +another language that is specified immediate after +@schememodname[at-exp].} + +For example, @scheme[#, @hash-lang[] at-exp scheme/base] adds @"@"-reader +support to @scheme[scheme/base], so that + +@schememod[ +at-exp scheme/base + +(define (greet who) #, @elem{@tt["@"]@scheme[string-append]@schemeparenfont["{"]@schemevalfont{Hello, }@tt["@|"]@scheme[who]@tt["|"]@schemevalfont{.}@schemeparenfont["}"]}) +(greet "friend")] + +reports @scheme["Hello, friend."]. + @;-------------------------------------------------------------------- @section{Interface} From 9858c507fb702608c538bc38bf918d30ade22189 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Feb 2009 23:16:47 +0000 Subject: [PATCH 044/142] note copy-and-paste bug generator in at-exp reader svn: r13732 --- collects/at-exp/lang/reader.ss | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/at-exp/lang/reader.ss b/collects/at-exp/lang/reader.ss index 71ea0b2453..751e8b56b8 100644 --- a/collects/at-exp/lang/reader.ss +++ b/collects/at-exp/lang/reader.ss @@ -1,5 +1,7 @@ #lang scheme/base +;; FIXME: This code was largely cut-and-pasted from the planet reader. + (require syntax/readerr (only-in scribble/reader make-at-readtable)) From 3adbe091c39907a8f5e0a98b81aefb722f0e10b0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Feb 2009 23:21:36 +0000 Subject: [PATCH 045/142] fix bug (that was copied and pasted!) in planet and at-exp readers svn: r13733 --- collects/at-exp/lang/reader.ss | 2 +- collects/planet/lang/reader.ss | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/at-exp/lang/reader.ss b/collects/at-exp/lang/reader.ss index 751e8b56b8..36f3680347 100644 --- a/collects/at-exp/lang/reader.ss +++ b/collects/at-exp/lang/reader.ss @@ -10,7 +10,7 @@ get-info) (define (at-get in export-sym src line col pos mk-fail-thunk) - (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(\\s|$)" in)] + (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)] [bad (lambda (str eof?) ((if eof? raise-read-eof-error diff --git a/collects/planet/lang/reader.ss b/collects/planet/lang/reader.ss index ade1f83ed8..6b42cd9cf9 100644 --- a/collects/planet/lang/reader.ss +++ b/collects/planet/lang/reader.ss @@ -9,7 +9,7 @@ get-info) (define (planet-get in lang-mod export-sym src line col pos mk-fail-thunk) - (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(\\s|$)" in)] + (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)] [bad (lambda (str eof?) ((if eof? raise-read-eof-error @@ -35,7 +35,7 @@ (bad (cadr spec) #f)))))) (define (get-info in mod line col pos) - (planet-get in "/lang/langinfo" 'get-info (object-name in) line col pos + (planet-get in "/lang/reader" 'get-info (object-name in) line col pos (lambda (spec) (lambda () (lambda (tag) #f))))) (define (planet-read-fn in read-sym args src mod line col pos) From b3beb59142acd6e9747142e7df0abd1124fa0549 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 18 Feb 2009 23:45:10 +0000 Subject: [PATCH 046/142] made some progress on the rendering-of-the-world section svn: r13734 --- .../games/chat-noir/chat-noir-literate.ss | 656 ++++++++++-------- 1 file changed, 348 insertions(+), 308 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index fc731c121d..fec7d51660 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -849,15 +849,15 @@ except it has a smile. @chunk[ (define circle-radius 20) (define circle-spacing 22) - (define normal-color 'lightskyblue) (define on-shortest-path-color 'white) (define blocked-color 'black) (define under-mouse-color 'black) + - image> - image> + + @@ -867,282 +867,90 @@ except it has a smile. - image-tests> - image-tests> + + ] +The main function for drawing a world is @scheme[render-world]. +It is a fairly straightforward composition of helper functions. +First, it builds the image of a board, and then puts the cat on it. +Lastly, since the whiskers of the cat might now hang off of the edge +of the board (if the cat is on a leftmost or rightmost cell), +it trims them. + @chunk[ -;; render-world : world -> image -(define (render-world w) - (chop-whiskers - (overlay (board->image (world-board w) - (world-size w) - (on-cats-path? w) - (world-mouse-posn w)) - (move-pinhole - (cond - [(equal? (world-state w) 'cat-won) happy-cat] - [(equal? (world-state w) 'cat-lost) mad-cat] - [else thinking-cat]) - (- (cell-center-x (world-cat w))) - (- (cell-center-y (world-cat w)))))))] + (define/contract (render-world w) + (-> world? image?) + (chop-whiskers + (overlay/xy (render-board (world-board w) + (world-size w) + (on-cats-path? w) + (world-mouse-posn w)) + (cell-center-x (world-cat w)) + (cell-center-y (world-cat w)) + (cond + [(equal? (world-state w) 'cat-won) happy-cat] + [(equal? (world-state w) 'cat-lost) mad-cat] + [else thinking-cat]))))] -@chunk[ +Trimming the cat's whiskers amounts to removing any extra +space in the image that appears to the left or above the pinhole. +For example, the @scheme[rectangle] function returns +an image with a pinhole in the middle. So trimming 5x5 +rectangle results in a 3x3 rectangle with the pinhole +at (0,0). - (test - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'playing - 3 - (make-posn 0 0) - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) true) - false) - (move-pinhole thinking-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - - (test - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'cat-won - 3 - false - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) true) - false) - (move-pinhole happy-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - - (test - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'cat-lost - 3 - false - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) true) - false) - (move-pinhole mad-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - - (test - (render-world - (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - false - false)) - (overlay - (board->image (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - 3 - (lambda (x) false) - false) - (move-pinhole mad-cat - (- (cell-center-x (make-posn 1 1))) - (- (cell-center-y (make-posn 1 1)))))) - - (test - (render-world - (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn (cell-center-x (make-posn 0 1)) - (cell-center-y (make-posn 0 1))) - true)) - - (overlay - (board->image (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - 3 - (lambda (x) true) - (make-posn (cell-center-x (make-posn 0 1)) - (cell-center-y (make-posn 0 1)))) - (move-pinhole mad-cat - (- (cell-center-x (make-posn 1 1))) - (- (cell-center-y (make-posn 1 1))))))] +@chunk[ + (test (chop-whiskers (rectangle 5 5 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0))] + +The function uses @scheme[shrink] to remove all of the material above +and to the left of the pinhole. @chunk[ -;; chop-whiskers : image -> image -;; crops the image so that anything above or to the left of the pinhole is gone -(define (chop-whiskers img) +(define/contract (chop-whiskers img) + (-> image? image?) (shrink img 0 0 (- (image-width img) (pinhole-x img) 1) (- (image-height img) (pinhole-y img) 1)))] -@chunk[ - (test (chop-whiskers (rectangle 5 5 'solid 'black)) - (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) - (test (chop-whiskers (rectangle 6 6 'solid 'black)) - (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) +The @scheme[render-board] function uses @scheme[for/fold] to iterate +over all of the @scheme[cell]s in @scheme[cs]. It starts with +an empty rectangle and, one by one, puts the cells on @scheme[image]. - (test - (pinhole-x - (render-world - (make-world - (empty-board 3) - (make-posn 0 0) - 'playing - 3 - (make-posn 0 0) - false))) - 0) - (test - (pinhole-x - (render-world - (make-world - (empty-board 3) - (make-posn 0 1) - 'playing - 3 - (make-posn 0 0) - false))) - 0)] +@chunk[ + ;; render-board : board number (posn -> boolean) posn-or-false -> image + (define/contract (render-board cs world-size on-cat-path? mouse) + (-> (listof cell?) + natural-number/c + (-> posn? boolean?) + (or/c #f posn?) + image?) + (for/fold ([image (nw:rectangle (world-width world-size) + (world-height world-size) + 'solid + 'white)]) + ([c cs]) + (overlay image + (render-cell c + (on-cat-path? (cell-p c)) + (and (posn? mouse) + (equal? mouse (cell-p c)))))))] -@chunk[image> -;; board->image : board number (posn -> boolean) posn-or-false -> image - (define (board->image cs world-size on-cat-path? mouse) - (foldl (lambda (x y) (overlay y x)) - (nw:rectangle (world-width world-size) - (world-height world-size) - 'solid - 'white) - (map (lambda (c) - (cell->image c - (on-cat-path? (cell-p c)) - (and (posn? mouse) - (equal? mouse (cell-p c))) - #; - (and (posn? mouse) - (point-in-this-circle? (cell-p c) - (posn-x mouse) - (posn-y mouse))))) - cs)))] +The @scheme[render-cell] function accepts a @scheme[cell], +a boolean indicating if the cell is on the shortest path between +the cat and the boundary, and a second boolean indicating +if the cell is underneath the mouse. It returns an image +of the cell, with the pinhole placed in such a way that overlaying +the image on an empty image with pinhole in the upper-left corner +results in the cell being placed in the right place. -@chunk[image-tests> - (test (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) false) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false))) - - (test (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) true) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - true - false))) - - - (test (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) false) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false))) - - (test (board->image (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) (equal? x (make-posn 0 1))) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false) - (cell->image (make-cell (make-posn 0 1) false) - true - false))) - - (test (board->image (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) (equal? x (make-posn 0 1))) - (make-posn 0 0)) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - true) - (cell->image (make-cell (make-posn 0 1) false) - true - false)))] - -@chunk[image> - ;; cell->image : cell boolean boolean -> image - (define (cell->image c on-short-path? under-mouse?) +@chunk[ + (define/contract (render-cell c on-short-path? under-mouse?) + (-> cell? boolean? boolean? image?) (local [(define x (cell-center-x (cell-p c))) (define y (cell-center-y (cell-p c))) (define main-circle @@ -1165,52 +973,33 @@ except it has a smile. (- x) (- y))))] -@chunk[image-tests> - (test (cell->image (make-cell (make-posn 0 0) false) false false) - (move-pinhole (circle circle-radius 'solid normal-color) - (- circle-radius) - (- circle-radius))) - (test (cell->image (make-cell (make-posn 0 0) true) false false) - (move-pinhole (circle circle-radius 'solid 'black) - (- circle-radius) - (- circle-radius))) - (test (cell->image (make-cell (make-posn 0 0) false) true false) - (move-pinhole (overlay (circle circle-radius 'solid normal-color) - (circle (quotient circle-radius 2) 'solid - on-shortest-path-color)) - (- circle-radius) - (- circle-radius))) - (test (cell->image (make-cell (make-posn 0 0) false) true true) - (move-pinhole (overlay (circle circle-radius 'solid normal-color) - (circle (quotient circle-radius 2) 'solid - under-mouse-color)) - (- circle-radius) - (- circle-radius)))] +The @scheme[world-width] function computes the width of the rendered world, +given the world's size by finding the center of the rightmost posn, +and then adding an additional radius. @chunk[ - - ;; world-width : number -> number - ;; computes the width of the drawn world in terms of its size - (define (world-width board-size) + (define/contract (world-width board-size) + (-> natural-number/c number?) (local [(define rightmost-posn (make-posn (- board-size 1) (- board-size 2)))] (+ (cell-center-x rightmost-posn) circle-radius)))] +Similarly, the @scheme[world-height] function computest the +height of the rendered world, given the world's size. + @chunk[ - ;; world-height : number -> number - ;; computes the height of the drawn world in terms of its size - (define (world-height board-size) + (define/contract (world-height board-size) + (-> natural-number/c number?) (local [(define bottommost-posn (make-posn (- board-size 1) (- board-size 1)))] (+ (cell-center-y bottommost-posn) circle-radius)))] -@chunk[ - (test (world-width 3) 150) - (test (world-height 3) 116.208)] +The @scheme[cell-center-x] function returns the +@tt{x} coordinate of the @chunk[ - ;; cell-center-x : posn -> number - (define (cell-center-x p) + (define/contract (cell-center-x p) + (-> posn? number?) (local [(define x (posn-x p)) (define y (posn-y p))] (+ circle-radius @@ -1220,18 +1009,12 @@ except it has a smile. 0))))] @chunk[ - (test (cell-center-x (make-posn 0 0)) - circle-radius) (test (cell-center-x (make-posn 0 1)) - (+ circle-spacing circle-radius)) - (test (cell-center-x (make-posn 1 0)) - (+ (* 2 circle-spacing) circle-radius)) - (test (cell-center-x (make-posn 1 1)) - (+ (* 3 circle-spacing) circle-radius))] + (+ circle-spacing circle-radius))] @chunk[ - ;; cell-center-y : posn -> number - (define (cell-center-y p) + (define/contract (cell-center-y p) + (-> posn? number?) (local [(define y (posn-y p))] (+ circle-radius (* y circle-spacing 2 @@ -1239,13 +1022,9 @@ except it has a smile. ))))] @chunk[ - (test (cell-center-y (make-posn 1 1)) - (+ circle-radius (* 2 circle-spacing .866))) (test (cell-center-y (make-posn 1 0)) circle-radius)] - - @section{Handling Input} @chunk[ @@ -2127,6 +1906,267 @@ except it has a smile. (test (+/f 1 '∞) '∞) (test (+/f 1 2) 3)] +@chunk[ + + (test + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'playing + 3 + (make-posn 0 0) + false)) + (overlay + (render-board (list (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) true) + false) + (move-pinhole thinking-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + + (test + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-won + 3 + false + false)) + (overlay + (render-board (list (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) true) + false) + (move-pinhole happy-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + + (test + (render-world + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-lost + 3 + false + false)) + (overlay + (render-board (list (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) true) + false) + (move-pinhole mad-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + + (test + (render-world + (make-world (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3 + false + false)) + (overlay + (render-board (list + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + 3 + (lambda (x) false) + false) + (move-pinhole mad-cat + (- (cell-center-x (make-posn 1 1))) + (- (cell-center-y (make-posn 1 1)))))) + + (test + (render-world + (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + 'cat-lost + 3 + (make-posn (cell-center-x (make-posn 0 1)) + (cell-center-y (make-posn 0 1))) + true)) + + (overlay + (render-board (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + 3 + (lambda (x) true) + (make-posn (cell-center-x (make-posn 0 1)) + (cell-center-y (make-posn 0 1)))) + (move-pinhole mad-cat + (- (cell-center-x (make-posn 1 1))) + (- (cell-center-y (make-posn 1 1))))))] + +@chunk[ + (test (chop-whiskers (rectangle 6 6 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) + + (test + (pinhole-x + (render-world + (make-world + (empty-board 3) + (make-posn 0 0) + 'playing + 3 + (make-posn 0 0) + false))) + 0) + (test + (pinhole-x + (render-world + (make-world + (empty-board 3) + (make-posn 0 1) + 'playing + 3 + (make-posn 0 0) + false))) + 0)] + +@chunk[ + (test (render-board (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) false) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (render-cell (make-cell (make-posn 0 0) false) + false + false))) + + (test (render-board (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) true) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (render-cell (make-cell (make-posn 0 0) false) + true + false))) + + + (test (render-board (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) false) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (render-cell (make-cell (make-posn 0 0) false) + false + false))) + + (test (render-board (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) (equal? x (make-posn 0 1))) + false) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (render-cell (make-cell (make-posn 0 0) false) + false + false) + (render-cell (make-cell (make-posn 0 1) false) + true + false))) + + (test (render-board (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) (equal? x (make-posn 0 1))) + (make-posn 0 0)) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (render-cell (make-cell (make-posn 0 0) false) + false + true) + (render-cell (make-cell (make-posn 0 1) false) + true + false)))] + + +@chunk[ + (test (render-cell (make-cell (make-posn 0 0) false) false false) + (move-pinhole (circle circle-radius 'solid normal-color) + (- circle-radius) + (- circle-radius))) + (test (render-cell (make-cell (make-posn 0 0) true) false false) + (move-pinhole (circle circle-radius 'solid 'black) + (- circle-radius) + (- circle-radius))) + (test (render-cell (make-cell (make-posn 0 0) false) true false) + (move-pinhole (overlay (circle circle-radius 'solid normal-color) + (circle (quotient circle-radius 2) 'solid + on-shortest-path-color)) + (- circle-radius) + (- circle-radius))) + (test (render-cell (make-cell (make-posn 0 0) false) true true) + (move-pinhole (overlay (circle circle-radius 'solid normal-color) + (circle (quotient circle-radius 2) 'solid + under-mouse-color)) + (- circle-radius) + (- circle-radius)))] + + +@chunk[ + (test (world-width 3) 150) + (test (world-height 3) 116.208)] + +@chunk[ + (test (cell-center-x (make-posn 0 0)) + circle-radius) + (test (cell-center-x (make-posn 1 0)) + (+ (* 2 circle-spacing) circle-radius)) + (test (cell-center-x (make-posn 1 1)) + (+ (* 3 circle-spacing) circle-radius))] + +@chunk[ + (test (cell-center-y (make-posn 1 1)) + (+ circle-radius (* 2 circle-spacing .866)))] + + @section{Run, program, run} @chunk[ From 20e76d845ec1080f363b40d19002a959c46409d8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 19 Feb 2009 08:50:20 +0000 Subject: [PATCH 047/142] Welcome to a new PLT day. svn: r13736 --- 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 a92a2b2f17..fa5ab3bc9d 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "18feb2009") +#lang scheme/base (provide stamp) (define stamp "19feb2009") From 88f65f052c89612f795b792d27d84091d418d1f1 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 19 Feb 2009 17:57:35 +0000 Subject: [PATCH 048/142] Fixing docs re pcdata svn: r13745 --- collects/xml/xml.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index cb7a123ff0..55148fb4ed 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -71,13 +71,13 @@ and a @scheme[_misc] is an instance of the @scheme[comment] or @defstruct[document ([prolog prolog?] [element element?] - [misc (or/c comment? pcdata?)])]{ + [misc (listof (or/c comment? p-i?))])]{ Represents a document.} -@defstruct[prolog ([misc (listof (or/c comment? pcdata?))] +@defstruct[prolog ([misc (listof (or/c comment? p-i?))] [dtd (or/c document-type false/c)] - [misc2 (listof (or/c comment? pcdata?))])]{ + [misc2 (listof (or/c comment? p-i?))])]{ Represents a document prolog. The @scheme[make-prolog] binding is unusual: it accepts two or more arguments, and all arguments after the From 0e26cbb64662265b92a21bb624da8ecfba8583cd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 19 Feb 2009 18:03:57 +0000 Subject: [PATCH 049/142] tests svn: r13746 --- collects/xml/test.ss | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/collects/xml/test.ss b/collects/xml/test.ss index e0f0fc43fa..5d6f27ec58 100644 --- a/collects/xml/test.ss +++ b/collects/xml/test.ss @@ -2,7 +2,8 @@ ;; % mzscheme --require test.ss (module test mzscheme - (require xml/xml + (require xml/main + scheme/list scheme/port) @@ -101,6 +102,35 @@ END result-string expected-string))) + + ;; pis + (define a-pi (make-p-i #f #f "foo" "bar")) + (define a-p (make-prolog empty #f)) + (define a-p/pi (make-prolog (list a-pi) #f)) + (define a-d0 + (make-document a-p (make-element #f #f 'html empty empty) + empty)) + (define a-d1 + (make-document a-p (make-element #f #f 'html empty empty) + (list a-pi))) + (define a-d2 + (make-document a-p/pi (make-element #f #f 'html empty empty) + (list a-pi))) + + (define (test-string=? test result expected) + (unless (string=? result expected) + (report-err test result expected))) + + (test-string=? "Display XML w/o pis" + (with-output-to-string (lambda () (display-xml a-d0))) + "\n") + (test-string=? "Display XML w/ pi in doc-misc" + (with-output-to-string (lambda () (display-xml a-d1))) + "\n\n") + (test-string=? "Display XML w/ pi in doc-misc and prolog" + (with-output-to-string (lambda () (display-xml a-d2))) + "\n\n\n") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; done From 665e7220dfa99bba433bcea6266a8294ea0625c6 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 19 Feb 2009 18:10:49 +0000 Subject: [PATCH 050/142] Updating docs re pr10081 svn: r13747 --- collects/xml/xml.scrbl | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index 55148fb4ed..1b91c065db 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -4,12 +4,14 @@ scribble/eval (for-label scheme/base scheme/contract + scheme/list xml xml/plist)) @(define xml-eval (make-base-eval)) @(define plist-eval (make-base-eval)) @interaction-eval[#:eval xml-eval (require xml)] +@interaction-eval[#:eval xml-eval (require scheme/list)] @interaction-eval[#:eval plist-eval (require xml/plist)] @title{@bold{XML}: Parsing and Writing} @@ -81,7 +83,19 @@ Represents a document.} Represents a document prolog. The @scheme[make-prolog] binding is unusual: it accepts two or more arguments, and all arguments after the -first two are collected into the @scheme[misc2] field.} +first two are collected into the @scheme[misc2] field. + +@examples[ +#:eval xml-eval +(make-prolog empty #f) +(make-prolog empty #f (make-p-i #f #f "k1" "v1")) +(make-prolog empty #f (make-p-i #f #f "k1" "v1") + (make-p-i #f #f "k2" "v2")) +@(code:comment "This example breaks the contract by providing") +@(code:comment "a list rather than a comment or p-i") +(prolog-misc2 (make-prolog empty #f empty)) +] +} @defstruct[document-type ([name symbol?] [external external-dtd?] From 09b5ece200dce61541836a6418da9e122109eb9a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 19 Feb 2009 18:16:09 +0000 Subject: [PATCH 051/142] fixed a logger bug that Dave Herman reported svn: r13748 --- collects/drscheme/private/rep.ss | 7 +++---- collects/drscheme/private/unit.ss | 14 ++++++++------ 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 42f3eca0ca..110cb23119 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -1462,11 +1462,10 @@ TODO (define/private (reset-logger-messages) (set! logger-messages '()) (update-logger-gui #f)) - + (define/private (update-logger-gui command) - (let ([frame (get-frame)]) - (when frame - (send frame update-logger-window command)))) + (let ([tab (send definitions-text get-tab)]) + (send tab update-logger-window command))) (define/private (new-planet-info tag package) (let ([frame (get-frame)]) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 1c7d3dadc1..b53792251b 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -1,11 +1,6 @@ #lang scheme/base #| -logger: multiple tabs need to save logger visibilty state - -logger: thread for collecting user messages should be created under user auspicies. -logger: what about thread for forwarding log messages? - closing: warning messages don't have frame as parent..... @@ -1326,6 +1321,9 @@ module browser threading seems wrong. (send frame show/hide-log log-visible?)) (define/public-final (update-log) (send frame show/hide-log log-visible?)) + (define/public-final (update-logger-window command) + (when (is-current-tab?) + (send frame update-logger-window command))) (define current-planet-status #f) (define/public-final (new-planet-status a b) @@ -1412,6 +1410,7 @@ module browser threading seems wrong. ;; this is #f when the GUI has not been built yet. After ;; it becomes a tab-panel, it is always a tab-panel (altho the tab panel might not always be shown) (define logger-gui-tab-panel #f) + (define logger-gui-canvas #f) ;; logger-gui-text: (or/c #f (is-a?/c tab-panel%)) ;; this is #f when the GUI has not been built or when the logging panel is hidden @@ -1437,12 +1436,14 @@ module browser threading seems wrong. l] [show? (new-logger-text) + (send logger-gui-canvas set-editor logger-gui-text) (update-logger-window #f) (send logger-menu-item set-label (string-constant hide-log)) (append (remq logger-panel l) (list logger-panel))] [else (send logger-menu-item set-label (string-constant show-log)) (set! logger-gui-text #f) + (send logger-gui-canvas set-editor #f) (remq logger-panel l)])))] [else (when show? ;; if we want to hide and it isn't built yet, do nothing @@ -1455,7 +1456,8 @@ module browser threading seems wrong. (λ (tp evt) (update-logger-window #f))])) (new-logger-text) - (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text]) + (set! logger-gui-canvas + (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])) (send logger-menu-item set-label (string-constant hide-log)) (update-logger-window #f) (send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))]) From 09c6c96099c0ab5cc7762f8e8a9f2c4465213fd8 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 19 Feb 2009 22:15:58 +0000 Subject: [PATCH 052/142] add a test for const svn: r13750 --- collects/tests/honu/basic.honu | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/tests/honu/basic.honu b/collects/tests/honu/basic.honu index 42f3d46819..b05716e989 100644 --- a/collects/tests/honu/basic.honu +++ b/collects/tests/honu/basic.honu @@ -14,4 +14,6 @@ obj test(t, a, b){ } var x = 3; +const y = 2; test("x = 3", x, 3); +test("y = 2", y, 2); From 7b3d069f47c1527fe36c73a95fb6179554ed989c Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 19 Feb 2009 22:26:10 +0000 Subject: [PATCH 053/142] updates from mzscheme->scheme svn: r13751 --- collects/honu/main.ss | 173 +++++++++++++++++++++++------------------- 1 file changed, 94 insertions(+), 79 deletions(-) diff --git a/collects/honu/main.ss b/collects/honu/main.ss index a3573f4885..2e5501d0fd 100644 --- a/collects/honu/main.ss +++ b/collects/honu/main.ss @@ -1,14 +1,18 @@ -(module main "private/mzscheme.ss" +#lang scheme/base + + (require (for-syntax + syntax/stx + scheme/base + syntax/kerncase + syntax/define + syntax/context + syntax/name + "private/ops.ss" + "private/util.ss" + "private/contexts.ss" + )) - (require-for-syntax syntax/stx - "private/ops.ss" - "private/util.ss" - syntax/kerncase - syntax/name - "private/contexts.ss") - (begin-for-syntax - ;; these definitions are used as stop-lists in local-expand (define kernel-forms (kernel-form-identifier-list)) (define prop-expand-stop-forms (list* #'honu-typed @@ -20,6 +24,7 @@ (define type-name-expand-stop-forms (list #'honu-type-name)) + ;; -------------------------------------------------------- ;; Transformer procedure property and basic struct @@ -64,7 +69,7 @@ [(forall (id ...) rhs bindings) (append (map syntax-e (syntax->list #'(id ...))) (list '>-> (format-type #'rhs)))] - [_else `(??? ,(syntax-object->datum t))]))) + [_else `(??? ,(syntax->datum t))]))) ;; -------------------------------------------------------- ;; Parsing blocks @@ -83,7 +88,7 @@ (and (identifier? stx) (not (ormap (lambda (i) (delim-identifier=? stx i)) (list #'\; #'\,))) (not (operator? stx)))) - + (define (get-transformer stx) ;; if its an identifier and bound to a transformer return it (define (bound-transformer stx) @@ -113,7 +118,7 @@ [else (loop (cdr l))])))] [(and (stx-pair? first) (identifier? (stx-car first)) - (module-identifier=? #'#%angles (stx-car first))) + (free-identifier=? #'#%angles (stx-car first))) (let ([v (syntax-local-value (stx-car first) (lambda () #f))]) (and (honu-transformer? v) v))] [else #f])))) @@ -133,7 +138,8 @@ => (lambda (transformer) (let-values ([(code rest) (transformer body ctx)]) (k code rest)))] - [else (let-values ([(expr-stxs after-expr terminator) (extract-until body (list #'\;))]) + [else (let-values ([(expr-stxs after-expr terminator) + (extract-until body (list #'\;))]) (unless expr-stxs (raise-syntax-error #f @@ -177,7 +183,7 @@ ;; Since we're parsing an expression in a ;; declaration context, we're responsible for ;; getting the whole expression: - (let ([placeholder (datum->syntax-object #f (gensym))]) + (let ([placeholder (datum->syntax #f (gensym))]) (let-values ([(expr-stxs after-expr terminator) (extract-until (cons placeholder rest) (list #'\;))]) (unless expr-stxs (raise-syntax-error @@ -188,11 +194,11 @@ (cond [(eq? in-expr placeholder) expr] [(syntax? in-expr) - (datum->syntax-object in-expr - (loop (syntax-e in-expr)) - in-expr - in-expr - in-expr)] + (datum->syntax in-expr + (loop (syntax-e in-expr)) + in-expr + in-expr + in-expr)] [(pair? in-expr) (cons (loop (car in-expr)) (loop (cdr in-expr)))] [else in-expr]))]) @@ -272,9 +278,9 @@ (delim-identifier=? #'#%parens id) (delim-identifier=? #'#%angles id)))) (and (identifier? (stx-car stx)) - (hash-table-get op-table - (syntax-e (stx-car stx)) - (lambda () #f)))) + (hash-ref op-table + (syntax-e (stx-car stx)) + (lambda () #f)))) (raise-syntax-error 'expression "expected an operator, but found something else" @@ -362,8 +368,8 @@ [(not (op? (stx-car seq))) (loop (cdr seq) before op (cons (car seq) since))] [((if (prefix? op) >= >) - (hash-table-get precedence-table (prec-key (car seq)) (lambda () 0)) - (hash-table-get precedence-table (prec-key op) (lambda () 0))) + (hash-ref precedence-table (prec-key (car seq)) (lambda () 0)) + (hash-ref precedence-table (prec-key op) (lambda () 0))) (loop (cdr seq) (if op (append since (list op) before) @@ -550,11 +556,11 @@ (stx-car orig-stx) #'id)) (if (and (or (value-definition-context? ctx) - (not (module-identifier=? #'id #'function))) + (not (free-identifier=? #'id #'function))) (not (function-definition-context? ctx)) (not (prototype-context? ctx)) (identifier? (stx-car #'rest)) - (module-identifier=? #'set! (stx-car #'rest))) + (free-identifier=? #'set! (stx-car #'rest))) ;; -- Non-procedure declaration (if (function-definition-context? ctx) (raise-syntax-error @@ -595,7 +601,7 @@ (with-syntax ([((arg arg-type arg-type-name arg-pred-id arg-protect-id) ...) args] [(temp-id ...) (generate-temporaries (map car args))] [def-id (if (and (not (definition-context? ctx)) - (module-identifier=? #'id #'function)) + (free-identifier=? #'id #'function)) (or (syntax-local-infer-name #'id) (car (generate-temporaries '(function)))) #'id)]) @@ -614,7 +620,7 @@ (define-typed arg #f id arg-type arg-type-name arg-pred-id arg-protect-id temp-id) ... (honu-unparsed-block def-id type-name type-name-expr pred-id #t . body))))]) (if (and (not (definition-context? ctx)) - (module-identifier=? #'id #'function)) + (free-identifier=? #'id #'function)) ;; Anonymous function: ;; We may have to continue parsing... (finish-parsing-expression "anonymous function" @@ -663,7 +669,7 @@ (let-values ([(args-stx ->-stx result-stx) (let loop ([stx (stx-cdr (stx-car form))][args null]) (if (and (identifier? (stx-car stx)) - (module-identifier=? #'-> (stx-car stx))) + (free-identifier=? #'-> (stx-car stx))) (values (reverse args) (stx-car stx) (stx-cdr stx)) (loop (stx-cdr stx) (cons (stx-car stx) args))))]) (when (stx-null? result-stx) @@ -732,7 +738,7 @@ (let-values ([(args-stx >->-stx result-stx) (let loop ([stx (stx-cdr (stx-car form))][args null]) (if (and (identifier? (stx-car stx)) - (module-identifier=? #'>-> (stx-car stx))) + (free-identifier=? #'>-> (stx-car stx))) (values (reverse args) (stx-car stx) (stx-cdr stx)) (loop (stx-cdr stx) (cons (stx-car stx) args))))]) (when (stx-null? result-stx) @@ -789,7 +795,7 @@ (identifier? t) (or (and (identifier? t) (ormap (lambda (orig new) - (and (module-identifier=? t orig) + (and (free-identifier=? t orig) new)) orig-ids new-types)) t)] @@ -821,8 +827,8 @@ [(boolean? (syntax-e val-expr)) #'bool] [(identifier? val-expr) (cond - [(module-identifier=? #'false val-expr) #'bool] - [(module-identifier=? #'true val-expr) #'bool] + [(free-identifier=? #'false val-expr) #'bool] + [(free-identifier=? #'true val-expr) #'bool] [else #'obj])] [else #'obj])])) @@ -833,22 +839,22 @@ (syntax-case target-type (-> forall) [ttid (identifier? target-type) - (or (module-identifier=? #'obj target-type) + (or (free-identifier=? #'obj target-type) (and (identifier? val-type) - (module-identifier=? val-type target-type)) + (free-identifier=? val-type target-type)) (let ([val-type (if (not val-type) (apparent-type val-expr) val-type)]) (or (and (identifier? val-type) - (or (module-identifier=? val-type target-type) - (and (module-identifier=? #'num target-type) - (or (module-identifier=? val-type #'int) - (module-identifier=? val-type #'real))) - (and (module-identifier=? #'real target-type) - (or (module-identifier=? val-type #'int))))) + (or (free-identifier=? val-type target-type) + (and (free-identifier=? #'num target-type) + (or (free-identifier=? val-type #'int) + (free-identifier=? val-type #'real))) + (and (free-identifier=? #'real target-type) + (or (free-identifier=? val-type #'int))))) (if (and (identifier? val-type) - (module-identifier=? val-type #'obj)) + (free-identifier=? val-type #'obj)) #f (fail-k orig-val-expr val-type target-type)))))] [(-> (t-result-type t-result-protect-id) (t-arg-type t-arg-type-name t-arg-pred) ...) @@ -871,7 +877,7 @@ (do-fail)))) t-args v-args)))] [_else - (if (module-identifier=? val-type #'obj) + (if (free-identifier=? val-type #'obj) #f (do-fail))]))] [(forall (poly-id ...) poly-t bindings) @@ -892,7 +898,7 @@ (do-fail)))] [else (if (and (identifier? val-type) - (module-identifier=? val-type #'obj)) + (free-identifier=? val-type #'obj)) #f (do-fail))]))] [_else @@ -979,7 +985,7 @@ v)]))] [(lv ([(lhs ...) expr] ...) ... body) (ormap (lambda (id) - (module-identifier=? #'lv id)) + (free-identifier=? #'lv id)) (list #'let-values #'letrec-values #'letrec-syntaxes+values)) (extract-type #'body)] [(begin e ... last-expr) @@ -1146,9 +1152,9 @@ [(_ #%angles a (b ...)) #'(honu-type-app a b ...)] [(_ a b ...) - (datum->syntax-object #'a - (cons #'a #'(b ...)) - #'a)])) + (datum->syntax #'a + (cons #'a #'(b ...)) + #'a)])) (define-syntax (op-cast stx) (syntax-case stx (#%parens) @@ -1292,7 +1298,7 @@ (define-syntax (honu-type-info stx) (raise-syntax-error #f "shouldn't appear unquoted!" stx)) - (require-for-syntax syntax/context) + ;; (require-for-syntax syntax/context) (define-syntax (honu-block stx) ;; A block can have mixed exprs and defns. Wrap expressions with ;; `(define-values () ... (values))' as needed, and add a (void) @@ -1353,7 +1359,7 @@ (begin (unless (or (not proc-id) (not (syntax-e proc-id)) - (module-identifier=? #'type-name #'obj)) + (free-identifier=? #'type-name #'obj)) (error "no expression for type check; should have been " "caught earlier")) (reverse prev-exprs))) @@ -1362,8 +1368,8 @@ null))] [(and (stx-pair? (car exprs)) (identifier? (stx-car (car exprs))) - (or (module-identifier=? #'define-values (stx-car (car exprs))) - (module-identifier=? #'define-syntaxes (stx-car (car exprs))))) + (or (free-identifier=? #'define-values (stx-car (car exprs))) + (free-identifier=? #'define-syntaxes (stx-car (car exprs))))) (loop (cdr exprs) (cons (car exprs) (append @@ -1417,7 +1423,7 @@ ;; -------------------------------------------------------- ;; Defining a new transformer or new type - (require-for-syntax syntax/define) + ;; (require-for-syntax syntax/define) (define-syntax (define-honu-syntax stx) (let-values ([(id rhs) (normalize-definition stx #'lambda #f)]) (with-syntax ([id id] @@ -1622,7 +1628,7 @@ ;; Assume anything else is ok: (loop #'rest (cons #'something accum))]))]) (unless (block-context? ctx) - (unless (module-identifier=? id #'function) + (unless (free-identifier=? id #'function) (raise-syntax-error #f (format "named generic allowed only in a block context, not in ~a context" @@ -1632,7 +1638,7 @@ (with-syntax ([(poly-id ...) ids] [(poly-pred-id ...) (generate-temporaries ids)] [(poly-name-id ...) (generate-temporaries ids)] - [def-id (if (module-identifier=? id #'function) + [def-id (if (free-identifier=? id #'function) (or (syntax-local-infer-name id) (car (generate-temporaries '(function)))) id)] @@ -1685,7 +1691,7 @@ (new-id honu-safe-use-hack) new-id)))))]) - (if (module-identifier=? id #'function) + (if (free-identifier=? id #'function) ;; Anonymous function: ;; We may have to continue parsing... (finish-parsing-expression "anonymous generic function" @@ -2035,6 +2041,7 @@ (honu-unparsed-begin #,@rest)))])) (define-syntax (#%dynamic-honu-module-begin stx) + ;; (printf "honu raw sexp ~a\n" (syntax->datum stx)) #`(#%plain-module-begin (honu-unparsed-begin #,@(stx-cdr stx)))) @@ -2071,31 +2078,39 @@ string -> >-> \; - (rename set! =) - (rename honu-return return) - (rename honu-if if) ? : - (rename honu-time time) - (rename honu-class class) - (rename honu+ +) (rename honu- -) (rename honu* *) - / (rename modulo %) - < > <= >= (rename equal? ==) != + ? : && \|\| - (rename string->number stringToNumber) - (rename number->string numberToString) - cons list - (rename car first) - (rename cdr rest) - (rename null empty) - (rename null? isEmpty) - (rename pair? isCons) - true false + / + < > <= >= + != + cons list + true false display write newline #%datum - #%top + #%top #%parens #%brackets #%braces #%angles #%prefix #%postfix - (rename #%dynamic-honu-module-begin #%module-begin) - (rename honu-#%app #%app) - define-honu-syntax - (rename honu-provide provide) - (rename honu-require require))) + define-honu-syntax + + (rename-out (set! =) + (honu-return return) + (honu-if if) + (honu-time time) + (honu-class class) + (honu+ +) + (honu- -) + (honu* *) + (modulo %) + (equal? ==) + (string->number stringToNumber) + (number->string numberToString) + (car first) + (cdr rest) + (null empty) + (null? isEmpty) + (pair? isCons) + (#%dynamic-honu-module-begin #%module-begin) + (honu-#%app #%app) + (honu-provide provide) + (honu-require require))) + From 84152a94f6e515126d89aa55e782a16dd6928dc9 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Fri, 20 Feb 2009 04:28:10 +0000 Subject: [PATCH 054/142] add examples for define-syntax and friends svn: r13752 --- collects/scribblings/reference/syntax.scrbl | 61 ++++++++++++++++++++- 1 file changed, 60 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index a7bd70bc88..baf5eda366 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -13,6 +13,11 @@ scheme/package scheme/splicing)) +@(define syntax-eval + (let ([the-eval (make-base-eval)]) + (the-eval '(require (for-syntax scheme/base))) + the-eval)) + @(define cvt (schemefont "CVT")) @(define unquote-id (scheme unquote)) @(define unquote-splicing-id (scheme unquote-splicing)) @@ -1602,6 +1607,21 @@ The second form is a shorthand the same as for @scheme[define]; it expands to a definition of the first form where the @scheme[expr] is a @scheme[lambda] form.} +@defexamples[#:eval syntax-eval +(define-syntax foo + (syntax-rules () + ((_ a ...) + (printf "~a\n" (list a ...))))) + +(foo 1 2 3 4) + +(define-syntax (bar syntax-object) + (syntax-case syntax-object () + ((_ a ...) + #'(printf "~a\n" (list a ...))))) + +(bar 1 2 3 4) +] @defform[(define-syntaxes (id ...) expr)]{ @@ -1610,6 +1630,24 @@ for each @scheme[id]. The @scheme[expr] should produce as many values as @scheme[id]s, and each value is bound to the corresponding @scheme[id]. } +@defexamples[#:eval syntax-eval +(define-syntaxes (foo1 foo2 foo3) + (let ([transformer1 (lambda (syntax-object) + (syntax-case syntax-object () + [(_) #'1]))] + [transformer2 (lambda (syntax-object) + (syntax-case syntax-object () + [(_) #'2]))] + [transformer3 (lambda (syntax-object) + (syntax-case syntax-object () + [(_) #'3]))]) + (values transformer1 + transformer2 + transformer3))) +(foo1) +(foo2) +(foo3) +] @defform*[[(define-for-syntax id expr) (define-for-syntax (head args) body ...+)]]{ @@ -1621,12 +1659,33 @@ expression for the binding is also at @tech{phase level} 1. (See Evaluation of @scheme[expr] side is @scheme[parameterize]d to set @scheme[current-namespace] as in @scheme[let-syntax].} +@defexamples[#:eval syntax-eval +(define-for-syntax foo 2) +(define-syntax bar + (lambda (syntax-object) + (printf "foo is ~a\n" foo) + #'2)) +(bar) +(define-syntax (bar2 syntax-object) + (printf "foo is ~a\n" foo) + #'3) +(bar2) +] + @defform[(define-values-for-syntax (id ...) expr)]{ Like @scheme[define-for-syntax], but @scheme[expr] must produce as -many value as supplied @scheme[id]s, and all of the @scheme[id]s are +many values as supplied @scheme[id]s, and all of the @scheme[id]s are bound (at @tech{phase level} 1).} +@defexamples[#:eval syntax-eval +(define-values-for-syntax (foo1 foo2) (values 1 2)) +(define-syntax (bar syntax-object) + (printf "foo1 is ~a foo2 is ~a\n" foo1 foo2) + #'2) +(bar) +] + @; ---------------------------------------------------------------------- @subsection[#:tag "require-syntax"]{@scheme[require] Macros} From 0e6c6a50132510be434c596fa654b22d08c42cd8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 20 Feb 2009 08:50:31 +0000 Subject: [PATCH 055/142] Welcome to a new PLT day. svn: r13753 --- 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 fa5ab3bc9d..7454cf1fad 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19feb2009") +#lang scheme/base (provide stamp) (define stamp "20feb2009") From 766308725436fe4eee40d38ec082c6897596468d Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Fri, 20 Feb 2009 21:05:08 +0000 Subject: [PATCH 056/142] add examples for require forms svn: r13754 --- collects/scribblings/reference/syntax.scrbl | 124 ++++++++++++++++++-- 1 file changed, 111 insertions(+), 13 deletions(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index baf5eda366..a246ed8739 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -14,9 +14,10 @@ scheme/splicing)) @(define syntax-eval - (let ([the-eval (make-base-eval)]) - (the-eval '(require (for-syntax scheme/base))) - the-eval)) + (lambda () + (let ([the-eval (make-base-eval)]) + (the-eval '(require (for-syntax scheme/base))) + the-eval))) @(define cvt (schemefont "CVT")) @(define unquote-id (scheme unquote)) @@ -200,6 +201,14 @@ be preserved in marshaled bytecode. See also See also @secref["module-eval-model"] and @secref["mod-parse"]. +@defexamples[#:eval (syntax-eval) +(module example-module scheme + (provide foo bar) + (define foo 2) + (define (bar x) + (+ x 1))) +] + @defform[(#%module-begin form ...)]{ Legal only in a @tech{module begin context}, and handled by the @@ -290,33 +299,122 @@ pre-defined forms are as follows. @scheme[_id] or as @scheme[_orig-id] in @scheme[[_orig-id _bind-id]]. If the @scheme[_id] or @scheme[_orig-id] of any @scheme[id-maybe-renamed] is not in the set that @scheme[require-spec] describes, a syntax - error is reported.} + error is reported. + + @defexamples[#:eval (syntax-eval) + (require (only-in scheme/tcp + tcp-listen + (tcp-accept my-accept))) + tcp-listen + my-accept + tcp-accept + ]} @defsubform[(except-in require-spec id ...)]{ Like @scheme[require-spec], but omitting those imports for which @scheme[id]s are the identifiers to bind; if any @scheme[id] is not in the set that @scheme[require-spec] describes, a syntax error is - reported.} + reported. + + @defexamples[#:eval (syntax-eval) + (require (except-in scheme/tcp + tcp-listen)) + tcp-accept + tcp-listen + ]} @defsubform[(prefix-in prefix-id require-spec)]{ Like @scheme[require-spec], but adjusting each identifier to be bound by prefixing it with @scheme[prefix-id]. The lexical context of the @scheme[prefix-id] is ignored, and instead preserved from the - identifiers before prefixing.} + identifiers before prefixing. + + @defexamples[#:eval (syntax-eval) + (require (prefix-in tcp: scheme/tcp)) + tcp:tcp-accept + tcp:tcp-listen + ]} @defsubform[(rename-in require-spec [orig-id bind-id] ...)]{ Like @scheme[require-spec], but replacing the identifier to bind @scheme[orig-id] with @scheme[bind-id]; if any @scheme[orig-id] is not in the set that @scheme[require-spec] - describes, a syntax error is reported.} + describes, a syntax error is reported. + + @defexamples[#:eval (syntax-eval) + (require (rename-in scheme/tcp + (tcp-accept accept) + (tcp-listen listen))) + accept + listen + ]} @defsubform[(combine-in require-spec ...)]{ - The union of the @scheme[require-spec]s.} + The union of the @scheme[require-spec]s. + + @defexamples[#:eval (syntax-eval) + (require (combine-in (only-in scheme/tcp tcp-accept) + (only-in scheme/tcp tcp-listen))) + tcp-accept + tcp-listen + ]} @defsubform[(only-meta-in phase-level require-spec ...)]{ Like the combination of @scheme[require-spec]s, but removing any binding that is not for @scheme[phase-level], where @scheme[#f] for - @scheme[phase-level] corresponds to the @tech{label phase level}.} + @scheme[phase-level] corresponds to the @tech{label phase level}. + + This example only imports bindings at @tech{phase level} 1, the + transform phase. + + @defexamples[#:eval (syntax-eval) + (module test scheme + + (provide (for-syntax meta-1a) + (for-meta 1 meta-1b) + meta-0) + + (define-for-syntax meta-1a 'a) + (define-for-syntax meta-1b 'b) + (define meta-0 2)) + + (require (only-meta-in 1 'test)) + + (define-syntax bar + (lambda (stx) + (printf "~a\n" meta-1a) + (printf "~a\n" meta-1b) + #'1)) + + (bar) + meta-0 + ] + + This example only imports bindings at @tech{phase level} 0, the + normal phase. + + @defexamples[#:eval (syntax-eval) + (module test scheme + + (provide (for-syntax meta-1a) + (for-meta 1 meta-1b) + meta-0) + + (define-for-syntax meta-1a 'a) + (define-for-syntax meta-1b 'b) + (define meta-0 2)) + + (require (only-meta-in 0 'test)) + + (define-syntax bar + (lambda (stx) + (printf "~a\n" meta-1a) + (printf "~a\n" meta-1b) + #'1)) + + meta-0 + (bar) + ]} @specsubform[#:literals (for-meta) (for-meta phase-level require-spec ...)]{Like the combination of @@ -1607,7 +1705,7 @@ The second form is a shorthand the same as for @scheme[define]; it expands to a definition of the first form where the @scheme[expr] is a @scheme[lambda] form.} -@defexamples[#:eval syntax-eval +@defexamples[#:eval (syntax-eval) (define-syntax foo (syntax-rules () ((_ a ...) @@ -1630,7 +1728,7 @@ for each @scheme[id]. The @scheme[expr] should produce as many values as @scheme[id]s, and each value is bound to the corresponding @scheme[id]. } -@defexamples[#:eval syntax-eval +@defexamples[#:eval (syntax-eval) (define-syntaxes (foo1 foo2 foo3) (let ([transformer1 (lambda (syntax-object) (syntax-case syntax-object () @@ -1659,7 +1757,7 @@ expression for the binding is also at @tech{phase level} 1. (See Evaluation of @scheme[expr] side is @scheme[parameterize]d to set @scheme[current-namespace] as in @scheme[let-syntax].} -@defexamples[#:eval syntax-eval +@defexamples[#:eval (syntax-eval) (define-for-syntax foo 2) (define-syntax bar (lambda (syntax-object) @@ -1678,7 +1776,7 @@ Like @scheme[define-for-syntax], but @scheme[expr] must produce as many values as supplied @scheme[id]s, and all of the @scheme[id]s are bound (at @tech{phase level} 1).} -@defexamples[#:eval syntax-eval +@defexamples[#:eval (syntax-eval) (define-values-for-syntax (foo1 foo2) (values 1 2)) (define-syntax (bar syntax-object) (printf "foo1 is ~a foo2 is ~a\n" foo1 foo2) From 33df6b2bfa456d9f07db77f257fecdfb7a8ad0da Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sat, 21 Feb 2009 00:14:17 +0000 Subject: [PATCH 057/142] fixed mouse event bug svn: r13756 --- collects/2htdp/private/check-aux.ss | 2 +- collects/2htdp/private/world.ss | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss index b0a404c4d7..ff81e7b968 100644 --- a/collects/2htdp/private/check-aux.ss +++ b/collects/2htdp/private/check-aux.ss @@ -59,7 +59,7 @@ (define (mouse-event->parts e) (define x (- (send e get-x) INSET)) (define y (- (send e get-y) INSET)) - (list x y (cond [(send e button-down?) 'button-down] + (values x y (cond [(send e button-down?) 'button-down] [(send e button-up?) 'button-up] [(send e dragging?) 'drag] [(send e moving?) 'move] diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss index 6daa9e326f..4e29a5882d 100644 --- a/collects/2htdp/private/world.ss +++ b/collects/2htdp/private/world.ss @@ -180,10 +180,12 @@ (when live (pkey (send e get-key-code)))) ;; deal with mouse events if live and within range (define/override (on-event e) - (define l (mouse-event->parts e)) + (define-values (x y me) (mouse-event->parts e)) (when live - (when (and (<= 0 (first l) width) (<= 0 (second l) height)) - (pmouse . l))))) + (cond + [(and (<= 0 x width) (<= 0 y height)) (pmouse x y me)] + [(memq me '(leave enter)) (pmouse x y me)] + [else (void)])))) (parent frame) (editor visible) (style '(no-hscroll no-vscroll)) From c886bfa4e2899ac42675fd573216cb075439bde0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Feb 2009 02:34:18 +0000 Subject: [PATCH 058/142] got thru 6 and started on 7 svn: r13757 --- .../games/chat-noir/chat-noir-literate.ss | 274 +++++++++--------- 1 file changed, 144 insertions(+), 130 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index fec7d51660..e3ba62d826 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,5 +1,8 @@ #reader "literate-reader.ss" +@(require (for-label scheme/math) ;; for 'pi' below + scheme/math) + @;{ The command to build this: @@ -847,13 +850,7 @@ except it has a smile. @section{Drawing the World} @chunk[ - (define circle-radius 20) - (define circle-spacing 22) - (define normal-color 'lightskyblue) - (define on-shortest-path-color 'white) - (define blocked-color 'black) - (define under-mouse-color 'black) - + @@ -872,12 +869,38 @@ except it has a smile. ] +There are a number of constants +that are given names to make the code +more readable. + +These first two constants give the radius +of the circles that are drawn on the board, +plus the radius of an invisible circle +that, if they were drawn on top of +the circles, would touch +each other. Accordingly, @scheme[circle-spacing] +is used when computing the positions of the circles, +but the circles are drawn using @scheme[circle-radius]. + +@chunk[ + (define circle-radius 20) + (define circle-spacing 22)] + +The other four constants specify the colors of the circles. + +@chunk[ + (define normal-color 'lightskyblue) + (define on-shortest-path-color 'white) + (define blocked-color 'black) + (define under-mouse-color 'black)] + The main function for drawing a world is @scheme[render-world]. It is a fairly straightforward composition of helper functions. First, it builds the image of a board, and then puts the cat on it. Lastly, since the whiskers of the cat might now hang off of the edge of the board (if the cat is on a leftmost or rightmost cell), -it trims them. +it trims them. This ensures that the image is always the same size +and that the pinhole is always in the upper-left corner of the window. @chunk[ (define/contract (render-world w) @@ -995,36 +1018,79 @@ height of the rendered world, given the world's size. (+ (cell-center-y bottommost-posn) circle-radius)))] The @scheme[cell-center-x] function returns the -@tt{x} coordinate of the +@tt{x} coordinate of the center of the cell specified +by @scheme[p]. + +For example, the first cell in +the third row (counting from @scheme[0]) is +flush with the edge of the screen, so its +center is just the radius of the circle that +is drawn. + +@chunk[ + (test (cell-center-x (make-posn 0 2)) + circle-radius)] + + +The first cell in the second row, in contrast +is offset from the third row by +@scheme[circle-spacing]. + +@chunk[ + (test (cell-center-x (make-posn 0 1)) + (+ circle-spacing circle-radius))] + + +The definition of @scheme[cell-center-x] +multiplies the @scheme[x] coordinate of +@scheme[p] by twice @scheme[circle-spacing] +and then adds @scheme[circle-radius] to move +over for the first circle. In addition +if the @scheme[y] coordinate is odd, then +it adds @scheme[circle-spacing], shifting +the entire line over. @chunk[ (define/contract (cell-center-x p) (-> posn? number?) - (local [(define x (posn-x p)) - (define y (posn-y p))] + (let ([x (posn-x p)] + [y (posn-y p)]) (+ circle-radius (* x circle-spacing 2) (if (odd? y) circle-spacing 0))))] -@chunk[ - (test (cell-center-x (make-posn 0 1)) - (+ circle-spacing circle-radius))] +The @scheme[cell-center-y] function computes the +@scheme[y] coordinate of a cell's location on +the screen. For example, the @scheme[y] +coordinate of the first row is +the radius of a circle, ensuring that +the first row is flush against the top of +the screen. -@chunk[ - (define/contract (cell-center-y p) - (-> posn? number?) - (local [(define y (posn-y p))] - (+ circle-radius - (* y circle-spacing 2 - .866 ;; .866 is an exact approximate to sin(pi/3) - ))))] - @chunk[ (test (cell-center-y (make-posn 1 0)) circle-radius)] +Because the grid is hexagonal, the @scheme[y] coordinates +of the rows do not have the same spacing as the @scheme[x] +coordinates. In particular, they are off by +@tt{sin(pi/3)}. We approximate that by @scheme[866/1000] +in order to keep the computations and test cases simple +and using exact numbers. +A more precise approximation would be +@(scheme #,(sin (/ pi 3))), but it is not necessary at +the screen resolution. + +@chunk[ + (define/contract (cell-center-y p) + (-> posn? number?) + (+ circle-radius + (* (posn-y p) + circle-spacing 2 + 866/1000)))] + @section{Handling Input} @chunk[ @@ -1033,7 +1099,6 @@ The @scheme[cell-center-x] function returns the - ] @@ -1042,7 +1107,6 @@ The @scheme[cell-center-x] function returns the - @@ -1051,35 +1115,30 @@ The @scheme[cell-center-x] function returns the @chunk[ (define (clack world x y evt) - (cond - [(equal? evt 'button-up) + (let ([new-mouse-posn + (and (not (eq? evt 'leave)) + (make-posn x y))]) + (update-world-posn (cond - [(and (equal? 'playing (world-state world)) - (point-in-a-circle? (world-board world) x y)) - (move-cat - (update-world-posn - (make-world (add-obstacle (world-board world) x y) - (world-cat world) - (world-state world) - (world-size world) - (world-mouse-posn world) - (world-h-down? world)) - (make-posn x y)))] - [else (update-world-posn world (make-posn x y))])] - [(equal? evt 'button-down) - world] - [(equal? evt 'drag) world] - [(equal? evt 'move) - (update-world-posn world (make-posn x y))] - [(equal? evt 'enter) - (update-world-posn world (make-posn x y))] - [(equal? evt 'leave) - (update-world-posn world false)]))] + [(and (equal? evt 'button-up) + (equal? 'playing (world-state world)) + (circle-at-point (world-board world) x y)) + => + (λ (circle) + (move-cat + (make-world (block-cell circle (world-board world)) + (world-cat world) + (world-state world) + (world-size world) + (world-mouse-posn world) + (world-h-down? world))))] + [else world]) + new-mouse-posn)))] @chunk[ (test (clack (make-world '() (make-posn 0 0) 'playing 3 false false) 1 1 'button-down) - (make-world '() (make-posn 0 0) 'playing 3 false false)) + (make-world '() (make-posn 0 0) 'playing 3 #f false)) (test (clack (make-world '() (make-posn 0 0) 'playing 3 false false) 1 1 'drag) (make-world '() (make-posn 0 0) 'playing 3 false false)) @@ -1123,7 +1182,7 @@ The @scheme[cell-center-x] function returns the 10 10 'button-down) - (make-world '() (make-posn 0 0) 'playing 3 (make-posn 0 0) false)) + (make-world '() (make-posn 0 0) 'playing 3 false false)) (test (clack (make-world (list (make-cell (make-posn 0 0) false) (make-cell (make-posn 1 1) false)) @@ -1179,7 +1238,7 @@ The @scheme[cell-center-x] function returns the (make-posn 1 1) 'cat-lost 3 - (make-posn 1 0) + false false)) (test (clack @@ -1210,7 +1269,7 @@ The @scheme[cell-center-x] function returns the (make-posn 2 0) 'cat-won 3 - (make-posn 1 0) + false false))] @chunk[ @@ -1220,10 +1279,10 @@ The @scheme[cell-center-x] function returns the [(equal? (world-state w) 'playing) (cond [(posn? p) - (local [(define mouse-spot - (circle-at-point (world-board w) - (posn-x p) - (posn-y p)))] + (let ([mouse-spot + (circle-at-point (world-board w) + (posn-x p) + (posn-y p))]) (make-world (world-board w) (world-cat w) (world-state w) @@ -1437,35 +1496,6 @@ The @scheme[cell-center-x] function returns the (test (<=/f 1 '∞) true) (test (<=/f '∞ '∞) true)] -@chunk[ - ;; add-obstacle : board number number -> board - (define (add-obstacle board x y) - (cond - [(empty? board) board] - [else - (local [(define cell (first board)) - (define cx (cell-center-x (cell-p cell))) - (define cy (cell-center-y (cell-p cell)))] - (cond - [(and (<= (- cx circle-radius) x (+ cx circle-radius)) - (<= (- cy circle-radius) y (+ cy circle-radius))) - (cons (make-cell (cell-p cell) true) - (rest board))] - [else - (cons cell (add-obstacle (rest board) x y))]))]))] - -@chunk[ - (test (add-obstacle (list (make-cell (make-posn 0 0) false)) - circle-spacing circle-spacing) - (list (make-cell (make-posn 0 0) true))) - (test (add-obstacle (list (make-cell (make-posn 0 0) false)) 100 100) - (list (make-cell (make-posn 0 0) false))) - (test (add-obstacle (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - circle-spacing circle-spacing) - (list (make-cell (make-posn 0 0) true) - (make-cell (make-posn 0 1) false)))] - @chunk[ ;; circle-at-point : board number number -> posn-or-false ;; returns the posn corresponding to cell where the x,y coordinates are @@ -1477,10 +1507,7 @@ The @scheme[cell-center-x] function returns the [(point-in-this-circle? (cell-p (first board)) x y) (cell-p (first board))] [else - (circle-at-point (rest board) x y)])])) - - (define (point-in-a-circle? board x y) - (posn? (circle-at-point board x y)))] + (circle-at-point (rest board) x y)])]))] @chunk[ (test (circle-at-point empty 0 0) false) @@ -1490,25 +1517,17 @@ The @scheme[cell-center-x] function returns the (make-posn 0 0)) (test (circle-at-point (list (make-cell (make-posn 0 0) false)) 0 0) - false) - - - (test (point-in-a-circle? empty 0 0) false) - (test (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - true) - (test (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) - 0 0) false)] @chunk[ ;; point-in-this-circle? : posn number number -> boolean (define (point-in-this-circle? p x y) - (local [(define center (+ (cell-center-x p) - (* (sqrt -1) (cell-center-y p)))) - (define p2 (+ x (* (sqrt -1) y)))] - (<= (magnitude (- center p2)) circle-radius)))] + (let ([center (+ (cell-center-x p) + (* (sqrt -1) + (cell-center-y p)))] + [p2 (+ x (* (sqrt -1) y))]) + (<= (magnitude (- center p2)) + circle-radius)))] @chunk[ (test (point-in-this-circle? (make-posn 0 0) @@ -1544,6 +1563,10 @@ The @scheme[cell-center-x] function returns the @section{Tests} +This section consists of some infrastructure for +maintaining tests, plus a pile of additional tests +for the other functions in this document + @chunk[ (define-syntax (test stx) @@ -1569,24 +1592,19 @@ The @scheme[cell-center-x] function returns the 'actual))])) (define test-count 0) -(define test-procs '()) (define (test/proc actual-thunk expected-thunk cmp line sexp) - (set! test-procs - (cons - (λ () - (set! test-count (+ test-count 1)) - (let ([actual (actual-thunk)] - [expected (expected-thunk)]) - (unless (cmp actual expected) - (error 'check-expect "test #~a~a\n ~s\n ~s\n" - test-count - (if line - (format " on line ~a failed:" line) - (format " failed: ~s" sexp)) - actual - expected)))) - test-procs))) + (set! test-count (+ test-count 1)) + (let ([actual (actual-thunk)] + [expected (expected-thunk)]) + (unless (cmp actual expected) + (error 'check-expect "test #~a~a\n ~s\n ~s\n" + test-count + (if line + (format " on line ~a failed:" line) + (format " failed: ~s" sexp)) + actual + expected)))) (define (same-sets? l1 l2) @@ -1597,12 +1615,7 @@ The @scheme[cell-center-x] function returns the (test (same-sets? (list) (list)) true) (test (same-sets? (list) (list 1)) false) (test (same-sets? (list 1) (list)) false) -(test (same-sets? (list 1 2) (list 2 1)) true) - -(define (run-tests) - (for-each (λ (t) (t)) (reverse test-procs)) - (printf "passed ~s tests\n" test-count) - (flush-output))] +(test (same-sets? (list 1 2) (list 2 1)) true)] @chunk[ (test (lookup-in-table empty (make-posn 1 2)) '∞) @@ -2152,7 +2165,7 @@ The @scheme[cell-center-x] function returns the @chunk[ (test (world-width 3) 150) - (test (world-height 3) 116.208)] + (test (world-height 3) #e116.208)] @chunk[ (test (cell-center-x (make-posn 0 0)) @@ -2164,14 +2177,12 @@ The @scheme[cell-center-x] function returns the @chunk[ (test (cell-center-y (make-posn 1 1)) - (+ circle-radius (* 2 circle-spacing .866)))] + (+ circle-radius (* 2 circle-spacing 866/1000)))] @section{Run, program, run} @chunk[ - (run-tests) - (let* ([board-size 11] [initial-board (add-n-random-blocked-cells @@ -2194,4 +2205,7 @@ The @scheme[cell-center-x] function returns the (on-redraw render-world) (on-key-event change) (on-mouse-event clack) - (void))] + (void)) + + (printf "passed ~s tests\n" test-count) + (flush-output)] From cc495b9fd05df41531742f8bbe2300553223c53f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Feb 2009 02:41:13 +0000 Subject: [PATCH 059/142] moved to htdp/2e universe teachpack svn: r13758 --- .../games/chat-noir/chat-noir-literate.ss | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index e3ba62d826..f29965a319 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -52,7 +52,7 @@ and some code that builds an initial world and starts the game. (require scheme/local scheme/list scheme/bool scheme/math lang/private/imageeq ;; don't like this require, but need it for image? (for-syntax scheme/base)) - (require htdp/world lang/posn scheme/contract) + (require 2htdp/universe lang/posn scheme/contract) graph> @@ -1015,7 +1015,8 @@ height of the rendered world, given the world's size. (-> natural-number/c number?) (local [(define bottommost-posn (make-posn (- board-size 1) (- board-size 1)))] - (+ (cell-center-y bottommost-posn) circle-radius)))] + (ceiling (+ (cell-center-y bottommost-posn) + circle-radius))))] The @scheme[cell-center-x] function returns the @tt{x} coordinate of the center of the cell specified @@ -2165,7 +2166,7 @@ for the other functions in this document @chunk[ (test (world-width 3) 150) - (test (world-height 3) #e116.208)] + (test (world-height 3) 117)] @chunk[ (test (cell-center-x (make-posn 0 0)) @@ -2183,6 +2184,9 @@ for the other functions in this document @section{Run, program, run} @chunk[ + (printf "passed ~s tests\n" test-count) + (flush-output) + (let* ([board-size 11] [initial-board (add-n-random-blocked-cells @@ -2198,14 +2202,10 @@ for the other functions in this document false false)]) - (big-bang (world-width board-size) - (world-height board-size) - 1 - initial-world) - (on-redraw render-world) - (on-key-event change) - (on-mouse-event clack) - (void)) - - (printf "passed ~s tests\n" test-count) - (flush-output)] + (big-bang initial-world + (on-draw render-world + (world-width board-size) + (world-height board-size)) + (on-key change) + (on-mouse clack)) + (void))] From fb0cc555f4775a78c8695a85fe0aad234d5b36c6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Feb 2009 02:48:14 +0000 Subject: [PATCH 060/142] manual move of the files to avoid the svn bug svn: r13759 --- collects/games/chat-noir/chat-noir-literate.ss | 2 +- .../chat-noir/literate-lang.ss => scribble/lp/lang/lang.ss} | 0 .../chat-noir/literate-reader.ss => scribble/lp/lang/reader.ss} | 2 +- 3 files changed, 2 insertions(+), 2 deletions(-) rename collects/{games/chat-noir/literate-lang.ss => scribble/lp/lang/lang.ss} (100%) rename collects/{games/chat-noir/literate-reader.ss => scribble/lp/lang/reader.ss} (86%) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index f29965a319..113d9df894 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,4 +1,4 @@ -#reader "literate-reader.ss" +#lang scribble/lp @(require (for-label scheme/math) ;; for 'pi' below scheme/math) diff --git a/collects/games/chat-noir/literate-lang.ss b/collects/scribble/lp/lang/lang.ss similarity index 100% rename from collects/games/chat-noir/literate-lang.ss rename to collects/scribble/lp/lang/lang.ss diff --git a/collects/games/chat-noir/literate-reader.ss b/collects/scribble/lp/lang/reader.ss similarity index 86% rename from collects/games/chat-noir/literate-reader.ss rename to collects/scribble/lp/lang/reader.ss index 3168c0fd4b..89707ae6d5 100644 --- a/collects/games/chat-noir/literate-reader.ss +++ b/collects/scribble/lp/lang/reader.ss @@ -1,5 +1,5 @@ #lang s-exp syntax/module-reader -"literate-lang.ss" +scribble/lp/lang/lang #:read read-inside #:read-syntax read-syntax-inside #:whole-body-readers? #t From 7cc03cb42fff7ec2281e448bec8122f27a22e74e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Feb 2009 03:16:11 +0000 Subject: [PATCH 061/142] moved the newly literate program scribbled docs for the chat noir into the actual docs for the games collection svn: r13761 --- .../games/{chat-noir => }/3x3-empty-board.png | Bin .../games/{chat-noir => }/7x7-empty-board.png | Bin .../{chat-noir => }/cat-distance-example.png | Bin collects/games/chat-noir/5x5-empty-board.png | Bin 4238 -> 0 bytes collects/games/chat-noir/chat-noir-doc.ss | 7 +- .../games/chat-noir/chat-noir-literate.ss | 8 +- collects/games/scribblings/chat-noir.scrbl | 72 ++---------------- .../lp-include.ss} | 42 +++++----- 8 files changed, 36 insertions(+), 93 deletions(-) rename collects/games/{chat-noir => }/3x3-empty-board.png (100%) rename collects/games/{chat-noir => }/7x7-empty-board.png (100%) rename collects/games/{chat-noir => }/cat-distance-example.png (100%) delete mode 100644 collects/games/chat-noir/5x5-empty-board.png rename collects/{games/chat-noir/literate-doc-wrapper.ss => scribble/lp-include.ss} (55%) diff --git a/collects/games/chat-noir/3x3-empty-board.png b/collects/games/3x3-empty-board.png similarity index 100% rename from collects/games/chat-noir/3x3-empty-board.png rename to collects/games/3x3-empty-board.png diff --git a/collects/games/chat-noir/7x7-empty-board.png b/collects/games/7x7-empty-board.png similarity index 100% rename from collects/games/chat-noir/7x7-empty-board.png rename to collects/games/7x7-empty-board.png diff --git a/collects/games/chat-noir/cat-distance-example.png b/collects/games/cat-distance-example.png similarity index 100% rename from collects/games/chat-noir/cat-distance-example.png rename to collects/games/cat-distance-example.png diff --git a/collects/games/chat-noir/5x5-empty-board.png b/collects/games/chat-noir/5x5-empty-board.png deleted file mode 100644 index 126e4074d8453e927d0f78d9dc5b150991339128..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4238 zcma)9c|4SR`^E@$7!4|>DTBgD7)!=3W1F#$rNl`Q3R$yn$uh<|Wo%3T70&v-R-fbSihy}Qv;k<9Bt>TSC zf=2zbdKUyIf=hKGdX| zf{qo!Qk;WrvdjL=M$`+BamGeQ0R8fV=UN?m=-0I2D&|q64-Mj*41LI@lR|n@Ta!QM3oZrN*nMJ!qgTli1ye#^>PQCJBB$V+gQlcM8bzCXM#j{io>qK~lYA4&i1jX3$prh@ zf-hk*w_Y_X5UMzQd^m%lsj9`=98_`8T|Z8*z5UpiBB`$P&>N%3&IS21xrb=oi}Sj^ z&&;B+UqqraBhzQq$YS5uZdUCDN1kZ7QPAgXR9Bgs%YFYH*4|$wuX=Awjbhb}lYYTQ zbssDzHcJ{jaL*6)m6L;={%BcP=YBs{#n37$v-3O0`r&*2*;9E{OFPVW!98H@v;L)M zDpv(@K-~fX$hNtbqIKLLX$U4>uN%UO5#s|@q z?6}AmZ*5wxWN6xA9<^Dvh-9JRpnROH60xn6&oZvR$T#V6b6Mr9+1bk3zHfbH6QV)c zgZ9~@E-eK`;_tK7b9-1n^pEl_FWpz%j*3|w9?tdLezq~g`rNsC>c?=>0A0MKc zuHX2^Z1*cIzj4Nc*BS_(8|kfWlwZ@QO;=Y_drVvk^)?qbHp&RGe?~3-`Z3|uE%F!>Ox88!b+Nwp=;f#2|O9NOp>8oSC`U7U$+URytt?uYQOT2c3#*!Vo0 zd35Tk$$K=CXv+-_7SlSp-Q)E6cChGq(0Fi~=)5?n$8~`mCIUhjF|4x`Gxo~3H{YL+ z);a2U!BJk9tRm2Z1#BlcmL zv7SP{J)9Qz8%nO`wx}t99hZUKjH9G|&m4~W?x2Yt5Ip36Nz=p@x!;Hz?1qy&Y(v=? zO#Ll}w~{}CrG)y^%3)P9CC*&Z|7AnaBbgME-qxMfmFDUh2k3Qi@PbNMj2)7Q;Rc6? z)c#B$D%XPAmJgh93x;uoPBVo&^_w9md9!PLh^dIjV) zw~x`LV#8O5OuneSL8+DJ=B@^(*}C=7mo>c#p#wcV8=4B1Y!7jI$?QRsbXzyyNuKpJ|N>T}L(;R28_HTNp{6H_&TRAA{8Z*<|7 zJ^)>JU{jo0iCiIc0fiqU<+T>13`s^Q>t!pkqIap|GHf94sdZmE0HiCMim5TLTSj~uFAqi*H9SAp9g<1F+6 zP`)99=sDv>H#ENAH|omqGqk1`+H5Y-gP5*>Qh=J=wpM$MQ?-D!2GRSz9Wac z=Xjl4ZMsuk;rVhgY{4U*`|4PMUgd?^q-Aku{rT^DhUef;{G53tqe8*aP8%lKeki=9aO${H8n zP17h$QuMy}gS}q`PpB{1@rN?`h^Y}qS8T^5PmE`!TMRUx+ImB6;(nfnMq;|-ZsR-> zMjFkX5+?JGm)+k(HrZs7Ph4+qGet_$oj8Fc6ox{wEpP=8qI9R|89-ivz^&7O$PgN8}h29s9}$| zY?9k$2@fCONm8UP9DnaxW?p+EZb(aepD8SaQCCV@ep0Y1jE_e7NV-Q$^?W3>7sEEn zV5QnQuD6q(G8r4~YUlBGRs70A_=V*#bsdzMhC#S|r@q)Swau3HD{3mZlPl|Dv3*sV ze#gaI@dc!X=qzkD=L3|r=X#KTR$#*7*_1ft*{t}?T>x(b9>bz2yZK4aSPVFekM%$V z6g;lN%Zo6P%`6j@Wfg0nOh?Ob2UKjfeg5B40_0c=9!gWSOn>6RT6^L@3wO`O+Ap6D zq5vmDgE{Hyz=_YRAxD4%PG_7>O#rN^S99`gtBfbv-$@kR`O+|=|o1~}{75V+}#3T8W2t=-lD1jJ*`tA`4Z-?`Caj?KZE>XV243ZX%x!G5tCX$OGE(y|F6cpVL3U5c+azC6e)G=gtW!cq5D_;WVMg0=iBvKPr! zhUeY?6anp#0DrtteBW%ey1bvvEz47G0ZWUr4YH)IHJIX<`|;?i-v<=1j^bmcSQyh^ zX-sW8fwX);NQ{7nfsG$!m1hT@QA?C2)Y$^3c^KP>PZRf}!;XyA6k9Byldde8!UYs|B-MbR7e$$mWB2*lC4-vZO^1 ziO>kiyRzchGUGsdKO~}jxg$JaOh6c5kK}ur6YsF^O zc)l@If44vqlTehZ%U1<;hDER!37{*0K24Xk=)mmhG6H~f{B>$FxP$@O?;<_-E`AmY z$p>Kd%eiKV+YKkfJ0!sPM4WCF&`_-_Tp+;I{`FYP`lI{7WNNCuDi`37JPypMy?*-` zJGKyrt+S@FleYhzwB2So>W%&Z(3NC#Rm#v$e>o4q6D(ivePa4deK-V_ z_x5dGsNc!8dk7Lph*y~aC~aR9y@<3982*6#!+@-4CmUn|Lp&?#pJ#4exx|ZbGxSqS z#9DX6U6S;dWyyYjA>%%%CJ7HnZkNdQsqFgpkr2=%4lPKGUhJJY^<||5{EIFSK$6V+ za)!S{5}dV|_oa}i+;t_@C&2W8@M*y-+TqV+-TCb&xfX@+C|Ka0Or0RyG<+~r2ydfs z*{~lCrH`~IxPv>X8Y5poht(K7q2q;V1)AYfP~VnTqq(O3gNJ09e=0bqxz^rqy#_!* z2h6it2dOjX5ShYc=-Pm}GqVna7bt^G#@_%0FoID>V6Wt!W8lcZ`P_Q16UbO*oeDnk z#n0C(WY1=BB~^qY1!VtFhSw8eQh}g|%KkBd3d4$(oNSKyR=m-3y>rrav45meH2Dr1 z?2DtWSX3eRh!H^BieKpf=^$SF5InRBs~wKonj)>c*c=T^ARDB_;lAYnl(rvEh6>@` z07cX=u#jNuZg1OZT9vn<7@_?E!1H@gjm=9@upYLtrb8rU*Eoj#+vxpoW3O<310T$+ z^}jm)Gv(jWu+nm(>+Q6NX+Sdv)$XKq>(*w2r^ z^uxJE8u^|4qL)&JZp{pfPaf%!YX0h^y!uQdCGHb&Kcys2o5bHLjs=Xw0WY@cT|hBW zPZ(n9^hneEK07xo%y_i)fwACcO}9urM5aQ)?mhe4pDHaIZ^vg>i~Y$FP*EykM_YrY zb_?U7kRWqIM0KN3kQ8`Xllqe7GJ5JsrFhz~#9$tmLO{hZze!S7pkHu0cCRpAC?6Lq zkC<9Y_cE8TXIj6RGmnKMrq-ng^9-swE*jrg!E<4r(4QKI`*uip;s%6`0Hsk=#t89( zC=+RtEZ;e3z8xW+6X%yiWN+6+rnTaD)FnQ|iu16n1p!4-J@-z6au2xA0@OpA`Vnyh z_BE4|(Q>bbLipGq2c*F@ixyq@o$%vKBDUetksYUp1ax)Oz=8y&kcZO9Coi>s#|pgQ zl_5b6JE2(;V8Qc$txf#Sawjt98D;Ehr6}#NT@1y$7<7MD{-c&M*KA|04VgbcNtN6y zi~H7Cd$T(SB?@2m5J5;Wb?2b0N+En9#=;7YSaBSdwYr7+XzmpO{KlUQIXiq=8N*Z} zxVNa}kRaadF@A>Zj1k3d$M!h*cz4d46d(;}ABmk1mIfc6oZdWL)~o->s1fz?*2(3B z9OWAhlUyE_Fzmjg>wlQ#$3+Z=LaicCqmdomotM^*CXvLRMp~3&B$tX(BrFxo%Ukx? Y?iq#&uQB9+zl$6gBTK_tg9|tQ1sII;ZU6uP diff --git a/collects/games/chat-noir/chat-noir-doc.ss b/collects/games/chat-noir/chat-noir-doc.ss index ccbe5ad660..f1d71a3a7d 100644 --- a/collects/games/chat-noir/chat-noir-doc.ss +++ b/collects/games/chat-noir/chat-noir-doc.ss @@ -1,3 +1,8 @@ #lang scribble/doc -@(require "literate-doc-wrapper.ss") +@(require scribble/lp-include scheme/include) +;; HACK: use a fake `module', which makes it possible to include a module +;; and get only its code in. +@(define-syntax-rule (module name base body ...) + (begin body ...)) + @(include "chat-noir-literate.ss") diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 113d9df894..930d24dd3b 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -10,6 +10,7 @@ mzc chat-noir-doc.ss && rm -rf chat-noir-doc && scribble ++xref-in setup/xref lo } +@;{would like to have [#:style 'toc] in the next line ... } @title{Chat Noir} @author[(link "http://www.eecs.northwestern.edu/~robby" "Robby Findler") @@ -41,7 +42,7 @@ the Chat Noir game in a @section{Overview} Chat Noir is implemented using @link["http://www.htdp.org/"]{HtDP}'s universe -library: @schememodname[teachpack/2htdp/universe] +library: @schememodname[2htdp/universe] (although it only uses the ``world'' portions of that library). The program is divided up into six parts: the world data definition, an implementation of breadth-first search, @@ -64,7 +65,8 @@ and some code that builds an initial world and starts the game. ] Each section also comes with a series of test cases that are collected into the -@chunkref[] chunk at the end of the program. +@scheme[] +chunk at the end of the program. @chunk[ @@ -461,7 +463,7 @@ and returns a @scheme[distance-table]. As you can see, the first thing it does is bind the free variable in @scheme[bfs] to the result of calling the @scheme[neighbors] function (defined in the chunk -@chunkref[]) and then it has the @chunkref[] chunk. In the body +@scheme[]) and then it has the @scheme[] chunk. In the body it calls the @scheme[bfs] function and then transforms the result, using @scheme[hash-map], into a list of @scheme[cell]s. diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl index d5ba2790dc..c3ce04f24c 100644 --- a/collects/games/scribblings/chat-noir.scrbl +++ b/collects/games/scribblings/chat-noir.scrbl @@ -1,69 +1,7 @@ #lang scribble/doc -@(require "common.ss") -@(require scheme/runtime-path (for-syntax scheme/port scheme/base scheme/path)) -@(define-runtime-path cn "../chat-noir/chat-noir.ss") +@(require scribble/lp-include scheme/include) +@;{ HACK: use a fake `module', which makes it possible to include a module and get only its code in.} +@(define-syntax-rule (module name base body ...) + (begin body ...)) -@gametitle["Chat Noir" "chat-noir" "Puzzle Game"] - -The goal of the game is to stop the cat from escaping the board. Each -turn you click on a circle, which prevents the cat from stepping on -that space, and the cat responds by taking a step. If the cat is -completely boxed in and thus unable reach the border, you win. If the -cat does reach the border, you lose. - -To get some insight into the cat's behavior, hold down the ``h'' -key. It will show you the cells that are on the cat's shortest path to -the edge, assuming that the cell underneath the mouse has been -blocked, so you can experiment to see how the shortest paths change -by moving your mouse around. - -The game was inspired by this one the one at -@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game -Design} and has essentially the same rules. It also inspired the final -project for the introductory programming course at the University of -Chicago in the fall of 2008. - -@;{ - -This is commented out, waiting for the literate programming stuff. - -This game is written in the -@link["http://www.htdp.org/"]{How to Design Programs} -Intermediate language. It is a model solution to the final project for -the introductory programming course at the University of Chicago in -the fall of 2008, as below. - -@(define-syntax (m stx) - (call-with-input-file - (build-path (path-only (syntax-source stx)) - 'up "chat-noir" "chat-noir.ss") - (lambda (port) - (port-count-lines! port) - #`(schemeblock - #,@ - (let loop () - (let* ([p (peeking-input-port port)] - [l (read-line p)]) - (cond - [(eof-object? l) '()] - [(regexp-match #rx"^[ \t]*$" l) - (read-line port) - (loop)] - [(regexp-match #rx"^ *;+" l) - => - (lambda (m) - (let-values ([(line col pos) (port-next-location port)]) - (read-line port) - (let-values ([(line2 col2 pos2) (port-next-location port)]) - (cons (datum->syntax - #f - `(code:comment ,(regexp-replace* #rx" " l "\u00a0")) - (list "chat-noir.ss" line col pos (- pos2 pos))) - (loop)))))] - [else - (cons (read-syntax "chat-noir.ss" port) - (loop))]))))) - #:mode 'text)) - -@m[] -} +@(include "../chat-noir/chat-noir-literate.ss") diff --git a/collects/games/chat-noir/literate-doc-wrapper.ss b/collects/scribble/lp-include.ss similarity index 55% rename from collects/games/chat-noir/literate-doc-wrapper.ss rename to collects/scribble/lp-include.ss index 030b3af629..0dc35fb3b6 100644 --- a/collects/games/chat-noir/literate-doc-wrapper.ss +++ b/collects/scribble/lp-include.ss @@ -3,10 +3,10 @@ ;; Use this module to create literate doc wrappers -- files that require the ;; literate code in a way that makes it a scribble file. -(provide include chunk chunkref - (all-from-out scribble/manual)) +(provide chunk (all-from-out scribble/manual)) -(require scribble/manual scribble/decode scribble/struct scheme/include +(require scribble/manual scribble/decode scribble/struct + scribble/scheme (for-syntax scheme/base syntax/boundmap)) (begin-for-syntax @@ -29,19 +29,23 @@ (identifier? #'name) (let ([n (get-chunk-number #'name)] [str (symbol->string (syntax-e #'name))]) - (with-syntax ([tag (if (n . > . 1) (format "~a:~a" str n) str)] - [(more ...) (if (n . > . 1) - #`((subscript (smaller #,(format "~a" n)))) - #`())] - [str str]) - #`(make-splice - (list (make-toc-element - #f - (list (elemtag '(chunk tag) - (bold (italic (scheme name)) " ::="))) - (list (smaller (elemref '(chunk tag) #:underline? #f - str more ...)))) - (schemeblock expr ...)))))])) + (if (n . > . 1) + #'(void) + (with-syntax ([tag str] + [str str]) + #`(begin + ;; ---- This is the new part -------- + (define-syntax name (make-element-id-transformer + (lambda (stx) #'(chunkref name)))) + ;; ---------------------------------- + (make-splice + (list (make-toc-element + #f + (list (elemtag '(chunk tag) + (bold (italic (scheme name)) " ::="))) + (list (smaller (elemref '(chunk tag) #:underline? #f + str)))) + (schemeblock expr ...)))))))])) (define-syntax (chunkref stx) (syntax-case stx () @@ -49,9 +53,3 @@ (identifier? #'id) (with-syntax ([str (format "~a" (syntax-e #'id))]) #'(elemref '(chunk str) #:underline? #f str))])) - -;; HACK: provide a fake `module', which makes it possible to include a module -;; and get only its code in. -(provide module) -(define-syntax-rule (module name base body ...) - (begin body ...)) From d23bdbbfaf0aee3de3e1c126196b156a779cb6eb Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 21 Feb 2009 03:33:33 +0000 Subject: [PATCH 062/142] Fix the RHSes of term-lets not being treated as unquoted when converted to lws. svn: r13762 --- collects/redex/private/bitmap-test.ss | 6 +++--- collects/redex/private/reduction-semantics.ss | 10 +++++++--- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/collects/redex/private/bitmap-test.ss b/collects/redex/private/bitmap-test.ss index ed2fc014ef..8d84edfcb6 100644 --- a/collects/redex/private/bitmap-test.ss +++ b/collects/redex/private/bitmap-test.ss @@ -64,11 +64,11 @@ (define-metafunction lang [(TL 1) (a - ,(term-let ((x 1)) + ,(term-let ((x (term 1))) (term x)) below-only)] [(TL 2) (a - ,(term-let ((x 1)) + ,(term-let ((x (term 1))) (term x)) beside below)]) @@ -78,7 +78,7 @@ (define-metafunction lang [(Name (name x-arg arg)) - ,(term-let ((x-term-let 1)) + ,(term-let ((x-term-let (term 1))) (term (x-where x-term-let))) (where x-where 2)]) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 979d5fa0b9..ebfed67542 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -318,8 +318,9 @@ [(fvars ...) fvars] [((where-id where-expr) ...) withs] [((bind-id . bind-pat) ...) - (append (extract-pattern-binds #'lhs) - (extract-term-let-binds #'rhs))]) + (extract-pattern-binds #'lhs)] + [((tl-id . tl-pat) ...) + (extract-term-let-binds #'rhs)]) #`(make-rule-pict 'arrow (to-lw lhs) (to-lw rhs) @@ -329,6 +330,9 @@ (list (cons (to-lw bind-id) (to-lw bind-pat)) ... + (cons (to-lw tl-id) + (to-lw/uq tl-pat)) + ... (cons (to-lw where-id) (to-lw where-expr)) ...))))])) @@ -1027,7 +1031,7 @@ (to-lw bind-pat)) ... (cons (to-lw rhs-bind-id) - (to-lw rhs-bind-pat)) + (to-lw/uq rhs-bind-pat)) ... (cons (to-lw where-id) (to-lw where-pat)) From f79d87bea50b11074d60a9abbf4b777974f069de Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 21 Feb 2009 08:50:20 +0000 Subject: [PATCH 063/142] Welcome to a new PLT day. svn: r13763 --- 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 7454cf1fad..75a1c0c4c6 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "20feb2009") +#lang scheme/base (provide stamp) (define stamp "21feb2009") From 5c7b1221186a05a9a257fccd6289357be89fc1e5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Feb 2009 13:30:01 +0000 Subject: [PATCH 064/142] fix swiatchble-button to lose its hilite state when its hidden svn: r13764 --- collects/mrlib/switchable-button.ss | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/collects/mrlib/switchable-button.ss b/collects/mrlib/switchable-button.ss index 4b56ab6170..b5563438c2 100644 --- a/collects/mrlib/switchable-button.ss +++ b/collects/mrlib/switchable-button.ss @@ -76,8 +76,16 @@ (define/override (enable e?) (unless (equal? disabled? (not e?)) (set! disabled? (not e?)) + (set! down? #f) + (set! in? #f) (refresh))) (define/override (is-enabled?) (not disabled?)) + + (define/override (on-superwindow-show show?) + (unless show? + (set! in? #f) + (set! down? #f)) + (super on-superwindow-show show?)) (define/override (on-event evt) (cond From 24e4fd407ba20d2eb14cbf1a0ce996e484d4d1d8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Feb 2009 13:30:22 +0000 Subject: [PATCH 065/142] chat-noir literate small repairs svn: r13765 --- .../games/{ => chat-noir}/3x3-empty-board.png | Bin .../games/{ => chat-noir}/7x7-empty-board.png | Bin .../{ => chat-noir}/cat-distance-example.png | Bin .../games/chat-noir/chat-noir-literate.ss | 18 +++++--- collects/games/scribblings/common.ss | 40 +++++++++++------- collects/scheme/private/struct-info.ss | 8 +++- collects/scribble/lp-include.ss | 12 ++++-- collects/scribble/lp/lang/lang.ss | 14 ++++-- collects/scribblings/reference/struct.scrbl | 28 +++++++----- 9 files changed, 79 insertions(+), 41 deletions(-) rename collects/games/{ => chat-noir}/3x3-empty-board.png (100%) rename collects/games/{ => chat-noir}/7x7-empty-board.png (100%) rename collects/games/{ => chat-noir}/cat-distance-example.png (100%) diff --git a/collects/games/3x3-empty-board.png b/collects/games/chat-noir/3x3-empty-board.png similarity index 100% rename from collects/games/3x3-empty-board.png rename to collects/games/chat-noir/3x3-empty-board.png diff --git a/collects/games/7x7-empty-board.png b/collects/games/chat-noir/7x7-empty-board.png similarity index 100% rename from collects/games/7x7-empty-board.png rename to collects/games/chat-noir/7x7-empty-board.png diff --git a/collects/games/cat-distance-example.png b/collects/games/chat-noir/cat-distance-example.png similarity index 100% rename from collects/games/cat-distance-example.png rename to collects/games/chat-noir/cat-distance-example.png diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 930d24dd3b..988029b213 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,7 +1,8 @@ #lang scribble/lp @(require (for-label scheme/math) ;; for 'pi' below - scheme/math) + scheme/math + games/scribblings/common) @;{ The command to build this: @@ -10,8 +11,7 @@ mzc chat-noir-doc.ss && rm -rf chat-noir-doc && scribble ++xref-in setup/xref lo } -@;{would like to have [#:style 'toc] in the next line ... } -@title{Chat Noir} +@gametitle*["Chat Noir" "chat-noir" "Puzzle Game" #:style '(toc)] @author[(link "http://www.eecs.northwestern.edu/~robby" "Robby Findler") (link "http://www.barzilay.org/" "Eli Barzilay") @@ -23,13 +23,15 @@ that space, and the cat responds by taking a step. If the cat is completely boxed in and thus unable reach the border, you win. If the cat does reach the border, you lose. +@play-margin-note["Chat Noir"] + To get some insight into the cat's behavior, hold down the ``h'' key. It will show you the cells that are on the cat's shortest path to the edge, assuming that the cell underneath the mouse has been blocked, so you can experiment to see how the shortest paths change by moving your mouse around. -The game was inspired by this one the one at +The game was inspired by the one at @link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game Design} and has essentially the same rules. It also inspired the final project for the introductory programming course at the University of @@ -39,6 +41,8 @@ The remainder of this document explains the implementation of the Chat Noir game in a @link["http://www.literateprogramming.com/"]{Literate Programming} style. +@local-table-of-contents[] + @section{Overview} Chat Noir is implemented using @link["http://www.htdp.org/"]{HtDP}'s universe @@ -167,7 +171,7 @@ The @scheme[empty-board] function builds a list of @scheme[cell]s that correspond to an empty board. For example, here's what an empty 7x7 board looks like, as a list of cells. -@image["7x7-empty-board.png"] +@image["chat-noir/7x7-empty-board.png"] It contains 7 rows and, with the exception of the first and last rows, each row contains 7 cells. Notice how the even and odd rows are offset @@ -183,7 +187,7 @@ The 3x3 board also has the same property that it consists of three rows, each with three cells, but where the first and last row are missing their left-most cells. -@image["3x3-empty-board.png"] +@image["chat-noir/3x3-empty-board.png"] And here is how that board looks as a list of cells. @@ -697,7 +701,7 @@ For example, in a world of size @scheme[7] with the cat at @scheme[(make-posn 2 2)], the circles with white centers are on the shortest path to the boundary: -@image["cat-distance-example.png"] +@image["chat-noir/cat-distance-example.png"] So we can formulate two test cases using this world, one in the white circles and one not: diff --git a/collects/games/scribblings/common.ss b/collects/games/scribblings/common.ss index 8dfedc8bcb..8cac002f69 100644 --- a/collects/games/scribblings/common.ss +++ b/collects/games/scribblings/common.ss @@ -6,26 +6,36 @@ setup/main-collects) (provide (all-from-out scribble/manual) selflink - gametitle + gametitle gametitle* play-margin-note game) (define (selflink str) (link str (tt str))) (define game onscreen) -(define (gametitle name subcol subtitle) +(define (gametitle name subcol subtitle + #:style [style #f]) (make-splice (list - (title #:tag subcol - (make-element - "noborder" - (list - (image (path->main-collects-relative - (build-path (collection-path "games" subcol) - (format "~a.png" subcol)))))) - " " (onscreen name) " --- " subtitle) - (margin-note "To play " - (onscreen name) - ", run the " - (exec "PLT Games") " program." - " (Under Unix, it's called " (exec "plt-games") ").")))) + (gametitle* name subcol subtitle #:style style) + (play-margin-note name)))) + +(define (gametitle* name subcol subtitle + #:style [style #f]) + (title #:tag subcol + #:style style + (make-element + "noborder" + (list + (image (path->main-collects-relative + (build-path (collection-path "games" subcol) + (format "~a.png" subcol)))))) + " " (onscreen name) " --- " subtitle)) + +(define (play-margin-note name) + (margin-note "To play " + (onscreen name) + ", run the " + (exec "PLT Games") " program." + " (Under Unix, it's called " (exec "plt-games") ").")) + diff --git a/collects/scheme/private/struct-info.ss b/collects/scheme/private/struct-info.ss index 16e38f8f47..8ccef0325c 100644 --- a/collects/scheme/private/struct-info.ss +++ b/collects/scheme/private/struct-info.ss @@ -39,12 +39,16 @@ (error 'extract-struct-info "struct-info procedure result not properly formed: ~e" v)))) - si))) + (if (set!-transformer? si) + (extract-struct-info (set!-transformer-procedure si)) + si)))) (define-values (struct-info?) (lambda (si) (or (struct-info-rec? si) - (struct-declaration-info? si)))) + (struct-declaration-info? si) + (and (set!-transformer? si) + (struct-info-rec? (set!-transformer-procedure si)))))) (define-values (struct-declaration-info?) (lambda (x) diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss index 0dc35fb3b6..2c68e8c195 100644 --- a/collects/scribble/lp-include.ss +++ b/collects/scribble/lp-include.ss @@ -32,12 +32,18 @@ (if (n . > . 1) #'(void) (with-syntax ([tag str] - [str str]) + [str str] + [((for-label-mod ...) ...) + (map (lambda (expr) + (syntax-case expr (require) + [(require mod ...) + #'(mod ...)] + [else null])) + (syntax->list #'(expr ...)))]) #`(begin - ;; ---- This is the new part -------- (define-syntax name (make-element-id-transformer (lambda (stx) #'(chunkref name)))) - ;; ---------------------------------- + (require (for-label for-label-mod ... ...)) (make-splice (list (make-toc-element #f diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss index f25595809f..7911f772d9 100644 --- a/collects/scribble/lp/lang/lang.ss +++ b/collects/scribble/lp/lang/lang.ss @@ -68,7 +68,7 @@ chunk-mentions)]) #`(begin body ... (let ([b-id (void)]) b-use) ...))) -(define-syntax (module-begin stx) +(define-syntax (literate-begin stx) (syntax-case stx () [(module-begin expr ...) (with-syntax @@ -98,6 +98,12 @@ #%provide))) (cons expanded (loop (cdr exprs)))] [else (loop (cdr exprs))]))]))]) - #'(#%module-begin - body-code ... - (tangle)))])) + #'(begin + body-code ... + (tangle)))])) + +(define-syntax (module-begin stx) + (syntax-case stx () + [(_ id exprs . body) + #'(#%module-begin + (literate-begin id exprs . body))])) diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 65da253f7c..1c45f97154 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -543,9 +543,7 @@ transformer to generate information about imported structure types, so that @scheme[match] and subtyping @scheme[define-struct] forms work within the unit. -The expansion-time information for a structure type is represented -either as a structure that encapsulates a procedure that takes no -arguments and returns a list of six element, or it can be represented +The expansion-time information for a structure type can be represented directly as a list of six elements (of the same sort that the encapsulated procedure must return): @@ -585,10 +583,18 @@ encapsulated procedure must return): } -Use @scheme[struct-info?] to recognize both forms of information, and -use @scheme[extract-struct-info] to obtain a list from either -representation. Use @scheme[make-struct-info] to encapsulate a -procedure that represents structure type information. +Instead of this direct representation, the representation can +be a structure created by @scheme[make-struct-info] (or an instance of +a subtype of @scheme[struct:struct-info]), which encapsulates a +procedure that takes no arguments and returns a list of six +elements. Finally, the representation can be an instance of a +structure type derived from @scheme[struct:struct-info] that also +implements @scheme[prop:procedure], and where the instance is further +is wrapped by @scheme[make-set!-transformer]. + +Use @scheme[struct-info?] to recognize all allowed forms of the +information, and use @scheme[extract-struct-info] to obtain a list +from any representation. The implementor of a syntactic form can expect users of the form to know what kind of information is available about a structure type. For @@ -606,15 +612,17 @@ type. @defproc[(struct-info? [v any/c]) boolean?]{ Returns @scheme[#t] if @scheme[v] is either a six-element list with -the correct shape for representing structure-type information, or a -procedure encapsulated by @scheme[make-struct-info].} +the correct shape for representing structure-type information, a +procedure encapsulated by @scheme[make-struct-info], or a structure +type derived from @scheme[struct:struct-info] and wrapped with +@scheme[make-set!-transformer].} @defproc[(checked-struct-info? [v any/c]) boolean?]{ Returns @scheme[#t] if @scheme[v] is a procedure encapsulated by @scheme[make-struct-info] and produced by @scheme[define-struct], but only when no parent type is specified or the parent type is also -specified through a transformer binding to such a value).} +specified through a transformer binding to such a value.} @defproc[(make-struct-info [thunk (-> (and/c struct-info? list?))]) struct-info?]{ From b3ab7d563ec35b438dcf7e2fd7c35e863ef2ae6b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Feb 2009 13:35:49 +0000 Subject: [PATCH 066/142] restore lost credit on Jewel game svn: r13766 --- collects/games/scribblings/jewel.scrbl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/games/scribblings/jewel.scrbl b/collects/games/scribblings/jewel.scrbl index aabe96c91d..a40ac11507 100644 --- a/collects/games/scribblings/jewel.scrbl +++ b/collects/games/scribblings/jewel.scrbl @@ -3,6 +3,8 @@ @gametitle["Jewel" "jewel" "3-D Skill Game"] +@author["Peter Ivanyi"] + The board is an 8 by 8 array of jewels of 7 types. You need to get 3 or more in a row horizontally or vertically in order to score points. You can swap any two jewels that are next to each other up and down or From 327fa47487930554e1dd2537a8fcb9ab5793f67b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Feb 2009 14:15:29 +0000 Subject: [PATCH 067/142] another scribble/lp/lang/lang repair svn: r13767 --- collects/scribble/lp/lang/lang.ss | 61 +++++++++++++++---------------- 1 file changed, 30 insertions(+), 31 deletions(-) diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss index 7911f772d9..c543eebe84 100644 --- a/collects/scribble/lp/lang/lang.ss +++ b/collects/scribble/lp/lang/lang.ss @@ -70,37 +70,36 @@ (define-syntax (literate-begin stx) (syntax-case stx () - [(module-begin expr ...) - (with-syntax - ([(body-code ...) - (let loop ([exprs (syntax->list #'(expr ...))]) - (cond - [(null? exprs) null] - [else - (let ([expanded - (local-expand (car exprs) - 'module - (append (kernel-form-identifier-list) - (syntax->list #'(provide - require - #%provide - #%require))))]) - (syntax-case expanded (begin) - [(begin rest ...) - (append (loop (syntax->list #'(rest ...))) - (loop (cdr exprs)))] - [(id . rest) - (ormap (lambda (kw) (free-identifier=? #'id kw)) - (syntax->list #'(require - provide - chunk - #%require - #%provide))) - (cons expanded (loop (cdr exprs)))] - [else (loop (cdr exprs))]))]))]) - #'(begin - body-code ... - (tangle)))])) + [(_ . exprs) + (let loop ([exprs #'exprs]) + (syntax-case exprs () + [() #'(tangle)] + [(expr . exprs) + (let ([expanded + (local-expand #'expr + 'module + (append (kernel-form-identifier-list) + (syntax->list #'(provide + require + chunk + #%provide + #%require))))]) + (syntax-case expanded (begin chunk require/chunk) + [(begin rest ...) + (loop (datum->syntax + expanded + (append + (syntax->list #'(rest ...)) + #'exprs)))] + [(id . _) + (ormap (lambda (kw) (free-identifier=? #'id kw)) + (syntax->list #'(require + provide + chunk + #%require + #%provide))) + #`(begin #,expanded (literate-begin . exprs))] + [else (loop #'exprs)]))]))])) (define-syntax (module-begin stx) (syntax-case stx () From 5fd53ac98db7f1f5506f3d17950483d25b3e59cb Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Feb 2009 16:38:09 +0000 Subject: [PATCH 068/142] fixed typo svn: r13769 --- collects/scribblings/reference/include.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/reference/include.scrbl b/collects/scribblings/reference/include.scrbl index 78ab8233a4..2fe0004d92 100644 --- a/collects/scribblings/reference/include.scrbl +++ b/collects/scribblings/reference/include.scrbl @@ -7,9 +7,9 @@ @defform/subs[#:literals (file lib) (include path-spec) - ([include-spec string - (file string) - (lib string ...+)])]{ + ([path-spec string + (file string) + (lib string ...+)])]{ Inlines the syntax in the file designated by @scheme[path-spec] in place of the @scheme[include] expression. From 5b8c2977f958f1b8c7906cf9388e2db742ea0105 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sat, 21 Feb 2009 16:45:13 +0000 Subject: [PATCH 069/142] added separate naming facilty svn: r13770 --- collects/2htdp/private/world.ss | 35 +++++++++++++-------------------- collects/2htdp/universe.ss | 6 +++++- 2 files changed, 19 insertions(+), 22 deletions(-) diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss index 4e29a5882d..b94a99ef97 100644 --- a/collects/2htdp/private/world.ss +++ b/collects/2htdp/private/world.ss @@ -49,8 +49,10 @@ (class* object% (start-stop<%>) (inspect #f) (init-field - world0 ;; World - (tick K)) ;; (U (World -> World) (list (World -> World) Nat)) + world0 ;; World + (name #f) ;; (U #f Symbol) + (register #f) ;; (U #f IP) + (tick K)) ;; (U (World -> World) (list (World -> World) Nat)) (init (on-key K) ;; World KeyEvent -> World @@ -59,8 +61,7 @@ (on-draw #f) ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat)) (stop-when False) ;; World -> Boolean (record? #f) ;; Boolean - (register #f)) ;; (U #f String (list String Symbol)) - + ) ;; ----------------------------------------------------------------------- (field (world world0)) @@ -79,39 +80,31 @@ ;; ----------------------------------------------------------------------- (field [*out* #f] ;; (U #f OutputPort), where to send messages to - [*rec* (make-custodian)] ;; Custodian, monitor traffic - [host (cond - [(string? register) register] - [(pair? register) (car register)] - [else register])] - [name (cond - [(string? register) (gensym 'world)] - [(pair? register) (second register)] - [else register])]) + [*rec* (make-custodian)]) ;; Custodian, monitor traffic) (define/private (register-with-host) (define FMTtry "unable to register with ~a after ~s tries") (define FMTcom "unable to register with ~a due to protocol problems") ;; try to register with the server n times - (define (register n) - (printf "trying to register with ~a ...\n" host) + (define (do-register n) + (printf "trying to register with ~a ...\n" register) (with-handlers ((tcp-eof? (lambda (x) - (error 'register FMTcom host))) + (error 'register FMTcom register))) (exn:fail:network? (lambda (x) (if (= n 1) - (error 'register FMTtry host TRIES) + (error 'register FMTtry register TRIES) (begin (sleep PAUSE) - (register (- n 1))))))) - (define-values (in out) (tcp-connect host SQPORT)) + (do-register (- n 1))))))) + (define-values (in out) (tcp-connect register SQPORT)) (tcp-send out `(REGISTER ,(if name name (gensym 'world)))) (if (eq? (tcp-receive in) 'okay) (values in out) (raise tcp-eof)))) ;; --- now register, obtain connection, and spawn a thread for receiving (parameterize ([current-custodian *rec*]) - (define-values (in out) (register TRIES)) + (define-values (in out) (do-register TRIES)) (define dis (text "the universe disappeared" 11 'red)) (define (RECEIVE) (sync @@ -271,7 +264,7 @@ (define/public (start!) (when draw (show-canvas)) - (when host (register-with-host))) + (when register (register-with-host))) (define/public (stop! w) (set! live #f) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index d26ef51db2..d4d4d80981 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -117,8 +117,12 @@ (lambda (p) (syntax-case p () [(host) #`(ip> #,tag host)] - [(ip name) #`(list (ip> #,tag ip) (symbol> #,tag name))] [_ (err tag p)])))] + [name (lambda (tag) + (lambda (p) + (syntax-case p () + [(n) #`(symbol> #,tag n)] + [_ (err tag p)])))] [record? (lambda (tag) (lambda (p) (syntax-case p () From 056e06cf8400ba977050b6911e25274be6a88998 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sat, 21 Feb 2009 16:51:36 +0000 Subject: [PATCH 070/142] added separate naming facilty: docs svn: r13771 --- .../2htdp/scribblings/universe.scrbl | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index b875e0a297..5dc66e3309 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -158,7 +158,7 @@ The design of a world program demands that you come up with a data @defform/subs[#:id big-bang #:literals (on-tick on-draw on-key on-mouse on-receive - stop-when register record?) + stop-when register record? name) (big-bang state-expr clause ...) ([clause (on-tick tick-expr) @@ -171,7 +171,7 @@ The design of a world program demands that you come up with a data (record? boolean-expr) (on-receive rec-expr) (register IP-expr) - (register IP-expr name-expr) + (name name-expr) ])]{ starts a @tech{world} program in the initial state specified with @@ -798,11 +798,11 @@ following shapes: } @item{ -@defform/none[(register ip-expr name-expr) - #:contracts - ([ip-expr string?] - [name-expr (or/c symbol? string?)])]{ - connect this world to a universe server @emph{under a specific} @scheme[name-expr].} +@defform[(name name-expr) + #:contracts + ([name-expr (or/c symbol? string?)])]{ + provide a name (@scheme[namer-expr]) to this world, which is used as the + title of the canvas and the name sent to the server.} } ] @@ -1636,12 +1636,13 @@ Finally, here is the third function, which renders the state as a scene: ; String -> WorldState ; create and hook up a world with the @scheme[LOCALHOST] server -(define (create-world name) +(define (create-world n) (big-bang WORLD0 (on-receive receive) - (on-draw (draw name)) + (on-draw (draw n)) (on-tick move) - (register LOCALHOST name))) + (name n) + (register LOCALHOST))) )) Now you can use @scheme[(create-world 'carl)] and @scheme[(create-world 'same)], From 121764e7b57f7906f4d7420bdfa938621e371e18 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Feb 2009 17:22:02 +0000 Subject: [PATCH 071/142] changed the way the literate program setup works svn: r13774 --- collects/games/chat-noir/README | 35 ++------- collects/games/chat-noir/chat-noir-doc.ss | 8 -- .../games/chat-noir/chat-noir-literate.ss | 10 +-- collects/games/scribblings/chat-noir.scrbl | 8 +- collects/scribble/lp-include.ss | 67 ++++------------- collects/scribble/lp/lang/lang.ss | 73 ++++++------------- collects/scribble/private/lp.ss | 68 +++++++++++++++++ 7 files changed, 113 insertions(+), 156 deletions(-) delete mode 100644 collects/games/chat-noir/chat-noir-doc.ss create mode 100644 collects/scribble/private/lp.ss diff --git a/collects/games/chat-noir/README b/collects/games/chat-noir/README index 9ab6d8f03f..c595d62661 100644 --- a/collects/games/chat-noir/README +++ b/collects/games/chat-noir/README @@ -2,30 +2,14 @@ These are the files for the literate version of Chat Noir. The files not mentioned are actually in use for Chat Noir that you get via PLT Games. - - chat-noir-literate.ss: the actual file containing the literate - description of the chat noir game, as well as the game itself, in - the chunks. - - - chat-noir-doc.ss: the wrapper file that you run via scribble to get - the rendered output. - - - literate-lang.ss: the language for running literate programs - (contains the tangler). - - - literate-reader.ss: the reader used for chat-noir-literate.ss to - put it into the literate-lang.ss. - -Files that begin with "literate" are the files that need to move to a -scribble library, if this experiment is successful. - Problems: - - the code is not hyperlinked in the scribble output-- this is due to - the confusion about how the requires should work in the two modes. + - handling multiple chunks is broken right now, so the + chunkref-introducting macro (in scribble/private/lp.ss) + is disabled. - - The char-noir-doc.ss file should be built when setup-plt runs on - this collection to build the documentation, ie, this file should - eventually be merged together with ../scribblings/chat-noir.scrbl. + - Need to make 'a-chunk' be a real macro, I expect. (used in + scribble/private/lp.ss) - hyperlink bound top-level identifiers to their bindings? @@ -33,13 +17,8 @@ Problems: - toc entries should not be underlined. - - identifiers in @chunks[] that refer to other chunks - should link to the (first) chunk definition. - - Or maybe just have a @chunkref[]? - To document: @chunk - @chunkref - scribble/lp (when it is added). \ No newline at end of file + scribble/lp (when it is added). + scribble/lp-include diff --git a/collects/games/chat-noir/chat-noir-doc.ss b/collects/games/chat-noir/chat-noir-doc.ss deleted file mode 100644 index f1d71a3a7d..0000000000 --- a/collects/games/chat-noir/chat-noir-doc.ss +++ /dev/null @@ -1,8 +0,0 @@ -#lang scribble/doc -@(require scribble/lp-include scheme/include) -;; HACK: use a fake `module', which makes it possible to include a module -;; and get only its code in. -@(define-syntax-rule (module name base body ...) - (begin body ...)) - -@(include "chat-noir-literate.ss") diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 988029b213..dceffa333f 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -4,13 +4,6 @@ scheme/math games/scribblings/common) -@;{ -The command to build this: - -mzc chat-noir-doc.ss && rm -rf chat-noir-doc && scribble ++xref-in setup/xref load-collections-xref --htmls chat-noir-doc.ss - -} - @gametitle*["Chat Noir" "chat-noir" "Puzzle Game" #:style '(toc)] @author[(link "http://www.eecs.northwestern.edu/~robby" "Robby Findler") @@ -2213,5 +2206,6 @@ for the other functions in this document (world-width board-size) (world-height board-size)) (on-key change) - (on-mouse clack)) + (on-mouse clack) + (name '|Chat Noir|)) (void))] diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl index c3ce04f24c..e705a0c166 100644 --- a/collects/games/scribblings/chat-noir.scrbl +++ b/collects/games/scribblings/chat-noir.scrbl @@ -1,7 +1,3 @@ #lang scribble/doc -@(require scribble/lp-include scheme/include) -@;{ HACK: use a fake `module', which makes it possible to include a module and get only its code in.} -@(define-syntax-rule (module name base body ...) - (begin body ...)) - -@(include "../chat-noir/chat-noir-literate.ss") +@(require scribble/lp-include) +@(lp-include "../chat-noir/chat-noir-literate.ss") diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss index 2c68e8c195..dfc75496a8 100644 --- a/collects/scribble/lp-include.ss +++ b/collects/scribble/lp-include.ss @@ -1,61 +1,20 @@ #lang scheme/base -;; Use this module to create literate doc wrappers -- files that require the -;; literate code in a way that makes it a scribble file. +(require scheme/include (for-syntax scheme/base) + (only-in scribble/private/lp chunk) + scribble/manual) -(provide chunk (all-from-out scribble/manual)) +(provide lp-include) -(require scribble/manual scribble/decode scribble/struct - scribble/scheme - (for-syntax scheme/base syntax/boundmap)) - -(begin-for-syntax - ;; maps chunk identifiers to a counter, so we can distinguish multiple uses - ;; of the same name - (define chunk-numbers (make-free-identifier-mapping)) - (define (get-chunk-number id) - (let ([n (add1 (free-identifier-mapping-get chunk-numbers id - (lambda () 0)))]) - (free-identifier-mapping-put! chunk-numbers id n) - n))) - -;; This is the doc-view implementation of `chunk', see "literate-lang.ss" for -;; the cide-view implementation. Defines `chunk' as a macro that typesets the -;; contained code. -(define-syntax (chunk stx) +(define-syntax (module stx) (syntax-case stx () - [(_ name expr ...) - ;; no need for more error checking, using chunk for the code will do that - (identifier? #'name) - (let ([n (get-chunk-number #'name)] - [str (symbol->string (syntax-e #'name))]) - (if (n . > . 1) - #'(void) - (with-syntax ([tag str] - [str str] - [((for-label-mod ...) ...) - (map (lambda (expr) - (syntax-case expr (require) - [(require mod ...) - #'(mod ...)] - [else null])) - (syntax->list #'(expr ...)))]) - #`(begin - (define-syntax name (make-element-id-transformer - (lambda (stx) #'(chunkref name)))) - (require (for-label for-label-mod ... ...)) - (make-splice - (list (make-toc-element - #f - (list (elemtag '(chunk tag) - (bold (italic (scheme name)) " ::="))) - (list (smaller (elemref '(chunk tag) #:underline? #f - str)))) - (schemeblock expr ...)))))))])) + [(module name base body ...) + (begin + #'(begin body ...))])) -(define-syntax (chunkref stx) +(define-syntax (lp-include stx) (syntax-case stx () - [(_ id) - (identifier? #'id) - (with-syntax ([str (format "~a" (syntax-e #'id))]) - #'(elemref '(chunk str) #:underline? #f str))])) + [(_ name) + (with-syntax ([there (datum->syntax stx 'there)]) + #'(include-at/relative-to here there name))])) + diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss index c543eebe84..6a2d95116c 100644 --- a/collects/scribble/lp/lang/lang.ss +++ b/collects/scribble/lp/lang/lang.ss @@ -1,8 +1,7 @@ #lang scheme/base (provide (except-out (all-from-out scheme/base) #%module-begin) - (rename-out [module-begin #%module-begin]) - chunk) + (rename-out [module-begin #%module-begin])) (require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase)) @@ -25,22 +24,6 @@ chunks id `(,@(mapping-get chunks id) ,@(map syntax-local-introduce exprs))))) -;; This is the code-view implementation of `chunk', see -;; "literate-doc-wrapper.ss" for the doc-view implementation. Defines -;; `chunk' as a macro that collects the code to be later reassembled -;; by `tangle'. -(define-syntax (chunk stx) - (syntax-case stx () - [(_ name expr ...) - (cond [(not (identifier? #'name)) - (raise-syntax-error #f "expected a chunk name" stx #'name)] - [(not (regexp-match? #rx"^<.*>$" (symbol->string (syntax-e #'name)))) - (raise-syntax-error - #f "chunk names must begin and end with angle brackets, <...>" - stx #'name)] - [else (add-to-chunk! #'name (syntax->list #'(expr ...))) - #'(void)])])) - (define-syntax (tangle stx) (define chunk-mentions '()) (define body @@ -68,41 +51,27 @@ chunk-mentions)]) #`(begin body ... (let ([b-id (void)]) b-use) ...))) -(define-syntax (literate-begin stx) - (syntax-case stx () - [(_ . exprs) - (let loop ([exprs #'exprs]) - (syntax-case exprs () - [() #'(tangle)] - [(expr . exprs) - (let ([expanded - (local-expand #'expr - 'module - (append (kernel-form-identifier-list) - (syntax->list #'(provide - require - chunk - #%provide - #%require))))]) - (syntax-case expanded (begin chunk require/chunk) - [(begin rest ...) - (loop (datum->syntax - expanded - (append - (syntax->list #'(rest ...)) - #'exprs)))] - [(id . _) - (ormap (lambda (kw) (free-identifier=? #'id kw)) - (syntax->list #'(require - provide - chunk - #%require - #%provide))) - #`(begin #,expanded (literate-begin . exprs))] - [else (loop #'exprs)]))]))])) +(define-for-syntax (extract-chunks exprs) + (let loop ([exprs exprs]) + (syntax-case exprs () + [() (void)] + [(expr . exprs) + (syntax-case #'expr (define-syntax quote-syntax) + [(define-values (lifted) (quote-syntax (a-chunk id body ...))) + (eq? (syntax-e #'a-chunk) 'a-chunk) + (begin + (add-to-chunk! #'id (syntax->list #'(body ...))) + (loop #'exprs))] + [_ + (loop #'exprs)])]))) (define-syntax (module-begin stx) (syntax-case stx () [(_ id exprs . body) - #'(#%module-begin - (literate-begin id exprs . body))])) + (let ([expanded + (expand `(,#'module scribble-lp-tmp-name scribble/private/lp + ,@(syntax->datum #'(id exprs . body))))]) + (syntax-case expanded () + [(module name lang (mb . stuff)) + (begin (extract-chunks #'stuff) + #'(#%module-begin (tangle)))]))])) diff --git a/collects/scribble/private/lp.ss b/collects/scribble/private/lp.ss new file mode 100644 index 0000000000..229afa89a7 --- /dev/null +++ b/collects/scribble/private/lp.ss @@ -0,0 +1,68 @@ +#lang scheme/base + +(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase) + scribble/scheme scribble/decode scribble/manual scribble/struct) + +(begin-for-syntax + ;; maps chunk identifiers to a counter, so we can distinguish multiple uses + ;; of the same name + (define chunk-numbers (make-free-identifier-mapping)) + (define (get-chunk-number id) + (let ([n (add1 (free-identifier-mapping-get chunk-numbers id + (lambda () 0)))]) + (free-identifier-mapping-put! chunk-numbers id n) + n))) + +(define-syntax (chunk stx) + (syntax-case stx () + [(_ name expr ...) + ;; no need for more error checking, using chunk for the code will do that + (identifier? #'name) + (let ([n (get-chunk-number #'name)] + [str (symbol->string (syntax-e #'name))]) + + (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) + + (if (n . > . 1) + (let ([str + (format + "need to handle secondary tags: ~a ~a\n" + n + str)]) + #`(begin + (italic #,str))) + (with-syntax ([tag str] + [str str] + [((for-label-mod ...) ...) + (map (lambda (expr) + (syntax-case expr (require) + [(require mod ...) + #'(mod ...)] + [else null])) + (syntax->list #'(expr ...)))]) + #`(begin + (require (for-label for-label-mod ... ...)) + ;; why does this happen twice? + #; + (define-syntax name (make-element-id-transformer + (lambda (stx) #'(chunkref name)))) + (make-splice + (list (make-toc-element + #f + (list (elemtag '(chunk tag) + (bold (italic (scheme name)) " ::="))) + (list (smaller (elemref '(chunk tag) #:underline? #f + str)))) + (schemeblock expr ...)))))))])) + +(define-syntax (chunkref stx) + (syntax-case stx () + [(_ id) + (identifier? #'id) + (with-syntax ([str (format "~a" (syntax-e #'id))]) + #'(elemref '(chunk str) #:underline? #f str))])) + + +(provide (all-from-out scheme/base + scribble/manual) + chunk) From a66ed082fb80a45e0c1a34d36f9b4b4ac792405f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Feb 2009 17:30:07 +0000 Subject: [PATCH 072/142] moved the literate version of chat noir over so it is used by plt-games now svn: r13776 --- .../games/chat-noir/chat-noir-literate.ss | 4 +- collects/games/chat-noir/chat-noir-module.ss | 5 - collects/games/chat-noir/chat-noir-unit.ss | 41 +- collects/games/chat-noir/chat-noir.ss | 1628 ----------------- 4 files changed, 27 insertions(+), 1651 deletions(-) delete mode 100644 collects/games/chat-noir/chat-noir-module.ss delete mode 100644 collects/games/chat-noir/chat-noir.ss diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index dceffa333f..066597b77e 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -2183,8 +2183,8 @@ for the other functions in this document @section{Run, program, run} @chunk[ - (printf "passed ~s tests\n" test-count) - (flush-output) + ;(printf "passed ~s tests\n" test-count) + ;(flush-output) (let* ([board-size 11] [initial-board diff --git a/collects/games/chat-noir/chat-noir-module.ss b/collects/games/chat-noir/chat-noir-module.ss deleted file mode 100644 index b00cff6de0..0000000000 --- a/collects/games/chat-noir/chat-noir-module.ss +++ /dev/null @@ -1,5 +0,0 @@ -(module chat-noir-module lang/htdp-intermediate-lambda - (require (lib "world.ss" "htdp")) -; (require "hash.ss") - (require (lib "include.ss" "scheme")) - (include "chat-noir.ss")) diff --git a/collects/games/chat-noir/chat-noir-unit.ss b/collects/games/chat-noir/chat-noir-unit.ss index 26bd3b08e1..d6407a9ef0 100644 --- a/collects/games/chat-noir/chat-noir-unit.ss +++ b/collects/games/chat-noir/chat-noir-unit.ss @@ -10,27 +10,36 @@ (provide game@) (define orig-namespace (current-namespace)) -(define-runtime-path chat-noir "chat-noir-module.ss") +(define-runtime-path chat-noir "chat-noir-literate.ss") (define-unit game@ (import) (export) (define ns (make-base-namespace)) - (parameterize ([current-namespace ns]) - (namespace-attach-module orig-namespace '(lib "mred.ss" "mred")) - (namespace-attach-module orig-namespace '(lib "class.ss" "scheme")) - (dynamic-require chat-noir #f)) ;; a hack. ;; this adds a help button to the world.ss window - (let ([fs (get-top-level-windows)]) - (unless (null? fs) - (let ([f (car fs)] - [show-help - (show-scribbling - '(lib "games/scribblings/games.scrbl") - "chat-noir")]) - (new button% - [parent f] - [callback (λ (x y) (show-help))] - [label (string-constant help)]))))) + (thread + (λ () + (let loop ([n 0]) + (when (n . < . 100) + (sleep 1/10) + (let ([fs (get-top-level-windows)]) + (cond + [(null? fs) + (loop (+ n 1))] + [else + (let ([f (car fs)] + [show-help + (show-scribbling + '(lib "games/scribblings/games.scrbl") + "chat-noir")]) + (new button% + [parent f] + [callback (λ (x y) (show-help))] + [label (string-constant help)]))])))))) + + (parameterize ([current-namespace ns]) + (namespace-attach-module orig-namespace '(lib "mred.ss" "mred")) + (namespace-attach-module orig-namespace '(lib "class.ss" "scheme")) + (dynamic-require chat-noir #f))) diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss deleted file mode 100644 index 4b0ddf7c71..0000000000 --- a/collects/games/chat-noir/chat-noir.ss +++ /dev/null @@ -1,1628 +0,0 @@ -;#lang scheme (require htdp/world lang/posn) (define-syntax (check-expect stx) #'(void)) - -(require "hash.ss") - -;; constants -(define circle-radius 20) -(define circle-spacing 22) - -(define normal-color 'lightskyblue) -(define on-shortest-path-color 'white) -(define blocked-color 'black) -(define under-mouse-color 'black) - -;; data definitions - -;; a world is: -;; (make-world board posn state number mouse posn-or-false boolean) -(define-struct world (board cat state size mouse-posn h-down?)) - -;; a state is either: -;; - 'playing -;; - 'cat-won -;; - 'cat-lost - -;; a board is -;; (listof cell) - -;; a cell is -;; (make-cell (make-posn int[0-board-size] -;; int[0-board-size]) -;; boolean) -(define-struct cell (p blocked?)) - - -; -; -; -; -; -; ;;;;; -; ;;;; -; ;;; -; ;;;; ;;; ; ;;;; ;;;; ;; ; ;;;; ;;; ; -; ;;;;;;; ;;;;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;; ;;; -; ; ;;;; ;;; ;;;;;;;;;;;;;;; ;; ;; ;;; ;;;; -; ;; ;;; ;;; ;;;; ;;; ;;; ; ;; ;;;; ;;; -; ;;;;;;; ;;; ;; ;;;; ; ;;; ;;; ;;; -; ;;; ;;; ;;;;;;;;;; ;;;;;;; ;; ;;; -; ;;;; ;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ;; ;;; -; ;;;;; ;;; ;;;;; ;; ;;;; ;;; -; ;;;; ;;; ;; ;; -; ;;;;;; ; -; - -;; a distance-map is -;; (listof dist-cells) - -;; a dist-cell is -;; - (make-dist-cell posn (number or '∞)) -(define-struct dist-cell (p n)) - - -;; build-bfs-table : world (or/c 'boundary posn) -> distance-table -(define (build-bfs-table world init-point) - (local [;; posn : posn - ;; dist : number - (define-struct queue-ent (posn dist)) - - (define neighbors/w (neighbors world)) - - (define (bfs queue dist-table) - (cond - [(empty? queue) dist-table] - [else - (local [(define hd (first queue))] - (cond - [(boolean? (hash-ref dist-table (queue-ent-posn hd) #f)) - (local [(define dist (queue-ent-dist hd)) - (define p (queue-ent-posn hd))] - (bfs - (append (rest queue) - (map (lambda (p) (make-queue-ent p (+ dist 1))) - (neighbors/w p))) - (hash-set dist-table p dist)))] - [else - (bfs (rest queue) dist-table)]))]))] - - (hash-map - (bfs (list (make-queue-ent init-point 0)) - (make-immutable-hash/list-init)) - make-dist-cell))) - -;; same-sets? : (listof X) (listof X) -> boolean -(define (same-sets? l1 l2) - (and (andmap (lambda (e1) (member e1 l2)) l1) - (andmap (lambda (e2) (member e2 l1)) l2))) - -(check-expect (same-sets? (list) (list)) true) -(check-expect (same-sets? (list) (list 1)) false) -(check-expect (same-sets? (list 1) (list)) false) -(check-expect (same-sets? (list 1 2) (list 2 1)) true) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(check-expect (same-sets? - (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3 (make-posn 0 0) false) - 'boundary) - (list - (make-dist-cell 'boundary 0) - - (make-dist-cell (make-posn 1 0) 1) - (make-dist-cell (make-posn 2 0) 1) - - (make-dist-cell (make-posn 0 1) 1) - (make-dist-cell (make-posn 1 1) 2) - (make-dist-cell (make-posn 2 1) 1) - - (make-dist-cell (make-posn 1 2) 1) - (make-dist-cell (make-posn 2 2) 1))) - true) - -(check-expect (same-sets? - (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3 (make-posn 0 0) false) - (make-posn 1 1)) - (list - (make-dist-cell 'boundary 2) - - (make-dist-cell (make-posn 1 0) 1) - (make-dist-cell (make-posn 2 0) 1) - - (make-dist-cell (make-posn 0 1) 1) - (make-dist-cell (make-posn 1 1) 0) - (make-dist-cell (make-posn 2 1) 1) - - (make-dist-cell (make-posn 1 2) 1) - (make-dist-cell (make-posn 2 2) 1))) - true) - -(check-expect (same-sets? - (build-bfs-table (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false) - 'boundary) - (list - (make-dist-cell 'boundary 0))) - true) - -(check-expect (same-sets? - (build-bfs-table (make-world (empty-board 5) - (make-posn 2 2) - 'playing - 5 - (make-posn 0 0) - false) - 'boundary) - (list - (make-dist-cell 'boundary 0) - - (make-dist-cell (make-posn 1 0) 1) - (make-dist-cell (make-posn 2 0) 1) - (make-dist-cell (make-posn 3 0) 1) - (make-dist-cell (make-posn 4 0) 1) - - (make-dist-cell (make-posn 0 1) 1) - (make-dist-cell (make-posn 1 1) 2) - (make-dist-cell (make-posn 2 1) 2) - (make-dist-cell (make-posn 3 1) 2) - (make-dist-cell (make-posn 4 1) 1) - - (make-dist-cell (make-posn 0 2) 1) - (make-dist-cell (make-posn 1 2) 2) - (make-dist-cell (make-posn 2 2) 3) - (make-dist-cell (make-posn 3 2) 2) - (make-dist-cell (make-posn 4 2) 1) - - (make-dist-cell (make-posn 0 3) 1) - (make-dist-cell (make-posn 1 3) 2) - (make-dist-cell (make-posn 2 3) 2) - (make-dist-cell (make-posn 3 3) 2) - (make-dist-cell (make-posn 4 3) 1) - - - (make-dist-cell (make-posn 1 4) 1) - (make-dist-cell (make-posn 2 4) 1) - (make-dist-cell (make-posn 3 4) 1) - (make-dist-cell (make-posn 4 4) 1))) - true) - -(check-expect (same-sets? - (build-bfs-table (make-world (block-cell - (make-posn 4 2) - (empty-board 5)) - (make-posn 2 2) - 'playing - 5 - (make-posn 0 0) - false) - 'boundary) - (list - (make-dist-cell 'boundary 0) - - (make-dist-cell (make-posn 1 0) 1) - (make-dist-cell (make-posn 2 0) 1) - (make-dist-cell (make-posn 3 0) 1) - (make-dist-cell (make-posn 4 0) 1) - - (make-dist-cell (make-posn 0 1) 1) - (make-dist-cell (make-posn 1 1) 2) - (make-dist-cell (make-posn 2 1) 2) - (make-dist-cell (make-posn 3 1) 2) - (make-dist-cell (make-posn 4 1) 1) - - (make-dist-cell (make-posn 0 2) 1) - (make-dist-cell (make-posn 1 2) 2) - (make-dist-cell (make-posn 2 2) 3) - (make-dist-cell (make-posn 3 2) 3) - - (make-dist-cell (make-posn 0 3) 1) - (make-dist-cell (make-posn 1 3) 2) - (make-dist-cell (make-posn 2 3) 2) - (make-dist-cell (make-posn 3 3) 2) - (make-dist-cell (make-posn 4 3) 1) - - - (make-dist-cell (make-posn 1 4) 1) - (make-dist-cell (make-posn 2 4) 1) - (make-dist-cell (make-posn 3 4) 1) - (make-dist-cell (make-posn 4 4) 1))) - true) - -(check-expect (same-sets? - (build-bfs-table (make-world (empty-board 5) - (make-posn 2 2) - 'playing - 5 - (make-posn 0 0) - false) - (make-posn 2 2)) - (list - (make-dist-cell 'boundary 3) - - (make-dist-cell (make-posn 1 0) 2) - (make-dist-cell (make-posn 2 0) 2) - (make-dist-cell (make-posn 3 0) 2) - (make-dist-cell (make-posn 4 0) 3) - - (make-dist-cell (make-posn 0 1) 2) - (make-dist-cell (make-posn 1 1) 1) - (make-dist-cell (make-posn 2 1) 1) - (make-dist-cell (make-posn 3 1) 2) - (make-dist-cell (make-posn 4 1) 3) - - (make-dist-cell (make-posn 0 2) 2) - (make-dist-cell (make-posn 1 2) 1) - (make-dist-cell (make-posn 2 2) 0) - (make-dist-cell (make-posn 3 2) 1) - (make-dist-cell (make-posn 4 2) 2) - - (make-dist-cell (make-posn 0 3) 2) - (make-dist-cell (make-posn 1 3) 1) - (make-dist-cell (make-posn 2 3) 1) - (make-dist-cell (make-posn 3 3) 2) - (make-dist-cell (make-posn 4 3) 3) - - - (make-dist-cell (make-posn 1 4) 2) - (make-dist-cell (make-posn 2 4) 2) - (make-dist-cell (make-posn 3 4) 2) - (make-dist-cell (make-posn 4 4) 3))) - true) - -(check-expect (lookup-in-table - (build-bfs-table (make-world (empty-board 5) - (make-posn 2 2) - 'playing - 5 - (make-posn 0 0) - false) - (make-posn 2 2)) - (make-posn 1 4)) - 2) - - -;; lookup-in-table : distance-map posn -> number or '∞ -;; looks for the distance as recorded in the table t, -;; if not found returns a distance of '∞ -(define (lookup-in-table t p) - (cond - [(empty? t) '∞] - [else (cond - [(equal? p (dist-cell-p (first t))) - (dist-cell-n (first t))] - [else - (lookup-in-table (rest t) p)])])) - -(check-expect (lookup-in-table empty (make-posn 1 2)) '∞) -(check-expect (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3)) - (make-posn 1 2)) - 3) -(check-expect (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3)) - (make-posn 1 2)) - '∞) - - -;; p : world -> posn -> boolean -;; returns true when the posn is on the shortest path -;; from the cat to the edge of the board, in the given world -(define (on-cats-path? w) - (cond - [(world-h-down? w) - (local [(define edge-distance-map (build-bfs-table w 'boundary)) - (define cat-distance-map (build-bfs-table w (world-cat w))) - (define cat-distance (lookup-in-table edge-distance-map - (world-cat w)))] - (cond - [(equal? cat-distance '∞) - (lambda (p) false)] - [else - (lambda (p) - (equal? (+/f (lookup-in-table cat-distance-map p) - (lookup-in-table edge-distance-map p)) - cat-distance))]))] - [else - (lambda (p) false)])) - -(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) true)) - (make-posn 1 0)) - true) -(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) false)) - (make-posn 1 0)) - false) -(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) true)) - (make-posn 2 1)) - false) -(check-expect ((on-cats-path? - (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 0 0) - true)) - (make-posn 0 1)) - false) - -;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) -;; computes the neighbors of a posn, for a given board size -(define (neighbors w) - (local [(define blocked - (map cell-p - (filter (lambda (c) - (or (cell-blocked? c) - (equal? (cell-p c) (world-mouse-posn w)))) - (world-board w)))) - (define boundary-cells (filter (lambda (p) - (and (not (member p blocked)) - (on-boundary? p (world-size w)))) - (map cell-p (world-board w))))] - (lambda (p) - (cond - [(member p blocked) - '()] - [(equal? p 'boundary) - boundary-cells] - [else - (local [(define x (posn-x p)) - (define y (posn-y p)) - (define adjacent-posns (adjacent p (world-size w))) - (define in-bounds - (filter (lambda (x) (in-bounds? x (world-size w))) - adjacent-posns))] - (filter - (lambda (x) (not (member x blocked))) - (cond - [(equal? in-bounds adjacent-posns) - in-bounds] - [else - (cons 'boundary in-bounds)])))])))) - -(check-expect ((neighbors (empty-world 11)) (make-posn 1 1)) - (adjacent (make-posn 1 1) 11)) -(check-expect ((neighbors (empty-world 11)) (make-posn 2 2)) - (adjacent (make-posn 2 2) 11)) -(check-expect ((neighbors (empty-world 3)) 'boundary) - (list (make-posn 0 1) - (make-posn 1 0) - (make-posn 1 2) - (make-posn 2 0) - (make-posn 2 1) - (make-posn 2 2))) -(check-expect ((neighbors (empty-world 11)) (make-posn 1 0)) - (list 'boundary - (make-posn 2 0) - (make-posn 0 1) - (make-posn 1 1))) -(check-expect ((neighbors (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false)) - (make-posn 1 1)) - '()) -(check-expect ((neighbors (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false)) - (make-posn 1 0)) - (list 'boundary (make-posn 2 0) (make-posn 0 1))) - - -;; adjacent : posn number -> (listof posn) -;; returns a list of the posns that are adjacent to -;; `p' on an infinite hex grid -(define (adjacent p board-size) - (local [(define x (posn-x p)) - (define y (posn-y p))] - (cond - [(even? y) - (list (make-posn (- x 1) (- y 1)) - (make-posn x (- y 1)) - (make-posn (- x 1) y) - (make-posn (+ x 1) y) - (make-posn (- x 1) (+ y 1)) - (make-posn x (+ y 1)))] - [else - (list (make-posn x (- y 1)) - (make-posn (+ x 1) (- y 1)) - (make-posn (- x 1) y) - (make-posn (+ x 1) y) - (make-posn x (+ y 1)) - (make-posn (+ x 1) (+ y 1)))]))) - -(check-expect (adjacent (make-posn 1 1) 11) - (list (make-posn 1 0) - (make-posn 2 0) - (make-posn 0 1) - (make-posn 2 1) - (make-posn 1 2) - (make-posn 2 2))) -(check-expect (adjacent (make-posn 2 2) 11) - (list (make-posn 1 1) - (make-posn 2 1) - (make-posn 1 2) - (make-posn 3 2) - (make-posn 1 3) - (make-posn 2 3))) - - - -;; on-boundary? : posn number -> boolean -(define (on-boundary? p board-size) - (or (= (posn-x p) 0) - (= (posn-y p) 0) - (= (posn-x p) (- board-size 1)) - (= (posn-y p) (- board-size 1)))) - -(check-expect (on-boundary? (make-posn 0 1) 13) true) -(check-expect (on-boundary? (make-posn 1 0) 13) true) -(check-expect (on-boundary? (make-posn 12 1) 13) true) -(check-expect (on-boundary? (make-posn 1 12) 13) true) -(check-expect (on-boundary? (make-posn 1 1) 13) false) -(check-expect (on-boundary? (make-posn 10 10) 13) false) - - -;; in-bounds? : posn number -> boolean -(define (in-bounds? p board-size) - (and (<= 0 (posn-x p) (- board-size 1)) - (<= 0 (posn-y p) (- board-size 1)) - (not (equal? p (make-posn 0 0))) - (not (equal? p (make-posn 0 (- board-size 1)))))) -(check-expect (in-bounds? (make-posn 0 0) 11) false) -(check-expect (in-bounds? (make-posn 0 1) 11) true) -(check-expect (in-bounds? (make-posn 1 0) 11) true) -(check-expect (in-bounds? (make-posn 10 10) 11) true) -(check-expect (in-bounds? (make-posn 0 -1) 11) false) -(check-expect (in-bounds? (make-posn -1 0) 11) false) -(check-expect (in-bounds? (make-posn 0 11) 11) false) -(check-expect (in-bounds? (make-posn 11 0) 11) false) -(check-expect (in-bounds? (make-posn 10 0) 11) true) -(check-expect (in-bounds? (make-posn 0 10) 11) false) - -;; <=/f : (number or '∞) (number or '∞) -> boolean -(define (<=/f a b) - (cond - [(equal? b '∞) true] - [(equal? a '∞) false] - [else (<= a b)])) -(check-expect (<=/f 1 2) true) -(check-expect (<=/f 2 1) false) -(check-expect (<=/f '∞ 1) false) -(check-expect (<=/f 1 '∞) true) -(check-expect (<=/f '∞ '∞) true) - -(define (+/f x y) - (cond - [(or (equal? x '∞) (equal? y '∞)) - '∞] - [else - (+ x y)])) - -(check-expect (+/f '∞ '∞) '∞) -(check-expect (+/f '∞ 1) '∞) -(check-expect (+/f 1 '∞) '∞) -(check-expect (+/f 1 2) 3) - - -; -; -; -; -; -; ;; ;;;; -; ;;;; ;;;;; -; ;;; ; -; ;;; ;;; ; ;;;; ;;;; ;;;;;; ;; ;;;; ;;;;;; ;; ;;;; ;;; -; ;;;;;;;;;;;;;; ;;;; ;;;;;;;;; ;; ;; ; ;;;;; ;;; ;;;; ;;;;;;; -; ;;;;;;;;; ;;; ;;;;;;;;;;;;;;; ;;; ;; ;; ;;; ;;; ;;;; ; ;;;; -; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;; ;;; -; ;; ;;;; ;;; ;; ;;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;;;; -; ;;;;;;;; ;;; ;;;;;;;;;; ;;; ;; ;;;;; ;;;; ;;; ;;; ;;; -; ;;;;;;;;;;;;;;;; ;;;;;;;;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; ;;;; ;;; -; ;;;;; ;;;; ;;;; ;;;;; ;;; -; ;;;;;;; ;;; -; ;;;;;; -; - - -;; render-world : world -> image -(define (render-world w) - (chop-whiskers - (overlay (board->image (world-board w) - (world-size w) - (on-cats-path? w) - (world-mouse-posn w)) - (move-pinhole - (cond - [(equal? (world-state w) 'cat-won) happy-cat] - [(equal? (world-state w) 'cat-lost) sad-cat] - [else thinking-cat]) - (- (cell-center-x (world-cat w))) - (- (cell-center-y (world-cat w))))))) - -(check-expect - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'playing - 2 - (make-posn 0 0) - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true) - false) - (move-pinhole thinking-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -(check-expect - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'cat-won - 2 - false - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true) - false) - (move-pinhole happy-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -(check-expect - (render-world - (make-world (list (make-cell (make-posn 0 1) false)) - (make-posn 0 1) - 'cat-lost - 2 - false - false)) - (overlay - (board->image (list (make-cell (make-posn 0 1) false)) - 2 - (lambda (x) true) - false) - (move-pinhole sad-cat - (- (cell-center-x (make-posn 0 1))) - (- (cell-center-y (make-posn 0 1)))))) - -(check-expect - (render-world - (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - false - false)) - (overlay - (board->image (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) - 3 - (lambda (x) false) - false) - (move-pinhole sad-cat - (- (cell-center-x (make-posn 1 1))) - (- (cell-center-y (make-posn 1 1)))))) - -(check-expect - (render-world - (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn (cell-center-x (make-posn 0 1)) - (cell-center-y (make-posn 0 1))) - true)) - - (overlay - (board->image (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - 3 - (lambda (x) true) - (make-posn (cell-center-x (make-posn 0 1)) - (cell-center-y (make-posn 0 1)))) - (move-pinhole sad-cat - (- (cell-center-x (make-posn 1 1))) - (- (cell-center-y (make-posn 1 1)))))) - -;; chop-whiskers : image -> image -;; crops the image so that anything above or to the left of the pinhole is gone -(define (chop-whiskers img) - (shrink img - 0 - 0 - (- (image-width img) (pinhole-x img) 1) - (- (image-height img) (pinhole-y img) 1))) - -(check-expect (chop-whiskers (rectangle 5 5 'solid 'black)) - (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) -(check-expect (chop-whiskers (rectangle 6 6 'solid 'black)) - (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) - -(check-expect - (pinhole-x - (render-world - (make-world - (empty-board 3) - (make-posn 0 0) - 'playing - 3 - (make-posn 0 0) - false))) - 0) -(check-expect - (pinhole-x - (render-world - (make-world - (empty-board 3) - (make-posn 0 1) - 'playing - 3 - (make-posn 0 0) - false))) - 0) - - -;; board->image : board number (posn -> boolean) posn-or-false -> image -(define (board->image cs world-size on-cat-path? mouse) - (foldl (lambda (x y) (overlay y x)) - (nw:rectangle (world-width world-size) - (world-height world-size) - 'solid - 'white) - (map (lambda (c) (cell->image c - (on-cat-path? (cell-p c)) - (and (posn? mouse) - (equal? mouse (cell-p c))) - #; - (and (posn? mouse) - (point-in-this-circle? (cell-p c) - (posn-x mouse) - (posn-y mouse))))) - cs))) - -(check-expect (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) false) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false))) - -(check-expect (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) true) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - true - false))) - - -(check-expect (board->image (list (make-cell (make-posn 0 0) false)) - 3 - (lambda (x) false) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false))) - -(check-expect (board->image (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) (equal? x (make-posn 0 1))) - false) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - false) - (cell->image (make-cell (make-posn 0 1) false) - true - false))) - -(check-expect (board->image (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - 3 - (lambda (x) (equal? x (make-posn 0 1))) - (make-posn 0 0)) - (overlay - (nw:rectangle (world-width 3) - (world-height 3) - 'solid - 'white) - (cell->image (make-cell (make-posn 0 0) false) - false - true) - (cell->image (make-cell (make-posn 0 1) false) - true - false))) - -;; cell->image : cell boolean boolean -> image -(define (cell->image c on-short-path? under-mouse?) - (local [(define x (cell-center-x (cell-p c))) - (define y (cell-center-y (cell-p c))) - (define main-circle - (cond - [(cell-blocked? c) - (circle circle-radius 'solid blocked-color)] - [else - (circle circle-radius 'solid normal-color)]))] - (move-pinhole - (cond - [under-mouse? - (overlay main-circle - (circle (quotient circle-radius 2) 'solid under-mouse-color))] - [on-short-path? - (overlay main-circle - (circle (quotient circle-radius 2) 'solid on-shortest-path-color))] - [else - main-circle]) - (- x) - (- y)))) - -(check-expect (cell->image (make-cell (make-posn 0 0) false) false false) - (move-pinhole (circle circle-radius 'solid normal-color) - (- circle-radius) - (- circle-radius))) -(check-expect (cell->image (make-cell (make-posn 0 0) true) false false) - (move-pinhole (circle circle-radius 'solid 'black) - (- circle-radius) - (- circle-radius))) -(check-expect (cell->image (make-cell (make-posn 0 0) false) true false) - (move-pinhole (overlay (circle circle-radius 'solid normal-color) - (circle (quotient circle-radius 2) 'solid on-shortest-path-color)) - (- circle-radius) - (- circle-radius))) -(check-expect (cell->image (make-cell (make-posn 0 0) false) true true) - (move-pinhole (overlay (circle circle-radius 'solid normal-color) - (circle (quotient circle-radius 2) 'solid under-mouse-color)) - (- circle-radius) - (- circle-radius))) - -;; world-width : number -> number -;; computes the width of the drawn world in terms of its size -(define (world-width board-size) - (local [(define rightmost-posn - (make-posn (- board-size 1) (- board-size 2)))] - (+ (cell-center-x rightmost-posn) circle-radius))) - -(check-expect (world-width 3) 150) - -;; world-height : number -> number -;; computes the height of the drawn world in terms of its size -(define (world-height board-size) - (local [(define bottommost-posn - (make-posn (- board-size 1) (- board-size 1)))] - (+ (cell-center-y bottommost-posn) circle-radius))) -(check-expect (world-height 3) 116.208) - - -;; cell-center-x : posn -> number -(define (cell-center-x p) - (local [(define x (posn-x p)) - (define y (posn-y p))] - (+ circle-radius - (* x circle-spacing 2) - (if (odd? y) - circle-spacing - 0)))) - -(check-expect (cell-center-x (make-posn 0 0)) - circle-radius) -(check-expect (cell-center-x (make-posn 0 1)) - (+ circle-spacing circle-radius)) -(check-expect (cell-center-x (make-posn 1 0)) - (+ (* 2 circle-spacing) circle-radius)) -(check-expect (cell-center-x (make-posn 1 1)) - (+ (* 3 circle-spacing) circle-radius)) - -;; cell-center-y : posn -> number -(define (cell-center-y p) - (local [(define y (posn-y p))] - (+ circle-radius - (* y circle-spacing 2 - .866 ;; .866 is an exact approximate to sin(pi/3) - )))) - -(check-expect (cell-center-y (make-posn 1 1)) - (+ circle-radius (* 2 circle-spacing .866))) -(check-expect (cell-center-y (make-posn 1 0)) - circle-radius) - - -; -; -; -; -; -; ;;;;; ;;;; ;;;;;; -; ;;; ;;;;; ;;;; -; ;;; ;;; -; ;;;;;; ;;; ; ;;;;;; ;;; ;;;; -; ;;; ;;;; ;;; ;;;;; ;;; ;;;; ;;; ;;;;;; -; ;;; ;;;;; ;;; ;;; ;;; ;;;;; ;;; ;;;;; -; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;;; -; ;;; ;; ;;; ;;; ;;;;;; -; ;;; ; ;;; ;;;; ;;; ; ;; ;; -; ;;; ; ;;;; ;;;;;;;;;; ; ;;;;; ;;;; -; ;;;; ;;;; -; -; -; - - -(define (clack world x y evt) - (cond - [(equal? evt 'button-up) - (cond - [(and (equal? 'playing (world-state world)) - (point-in-a-circle? (world-board world) x y)) - (move-cat - (update-world-posn - (make-world (add-obstacle (world-board world) x y) - (world-cat world) - (world-state world) - (world-size world) - (world-mouse-posn world) - (world-h-down? world)) - (make-posn x y)))] - [else (update-world-posn world (make-posn x y))])] - [(equal? evt 'button-down) - world] - [(equal? evt 'drag) world] - [(equal? evt 'move) - (update-world-posn world (make-posn x y))] - [(equal? evt 'enter) - (update-world-posn world (make-posn x y))] - [(equal? evt 'leave) - (update-world-posn world false)])) - -(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 false false) - 1 1 'button-down) - (make-world '() (make-posn 0 0) 'playing 1 false false)) -(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 false false) - 1 1 'drag) - (make-world '() (make-posn 0 0) 'playing 1 false false)) -(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 1 - false - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'move) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 1 - (make-posn 0 0) - false)) -(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 1 - false - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'enter) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 1 - (make-posn 0 0) - false)) -(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false) - 1 1 'leave) - (make-world '() (make-posn 0 0) 'playing 1 false false)) - -(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false) - 10 - 10 - 'button-down) - (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false)) - -(check-expect (clack (make-world (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'button-up) - (make-world (list (make-cell (make-posn 0 0) true) - (make-cell (make-posn 1 1) false)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 0 0) - false)) - - -(check-expect (clack (make-world '() (make-posn 0 0) 'cat-lost 1 (make-posn 0 0) false) - 10 - 10 - 'button-up) - (make-world '() (make-posn 0 0) 'cat-lost 1 (make-posn 0 0) false)) -(check-expect (clack - (make-world - (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'playing - 3 - false - false) - (cell-center-x (make-posn 1 0)) - (cell-center-y (make-posn 1 0)) - 'button-up) - (make-world - (list (make-cell (make-posn 1 0) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 1 0) - false)) - -(check-expect (clack - (make-world - (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'playing - 3 - false - false) - (cell-center-x (make-posn 1 0)) - (cell-center-y (make-posn 1 0)) - 'button-up) - (make-world - (list (make-cell (make-posn 1 0) true) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 2 0) - 'cat-won - 3 - (make-posn 1 0) - false)) - -;; update-world-posn/playing : world posn-or-false -> world -(define (update-world-posn w p) - (cond - [(equal? (world-state w) 'playing) - (cond - [(posn? p) - (local [(define mouse-spot - (circle-at-point (world-board w) - (posn-x p) - (posn-y p)))] - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - (cond - [(equal? mouse-spot (world-cat w)) - false] - [else - mouse-spot]) - (world-h-down? w)))] - [else - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - false - (world-h-down? w))])] - [else w])) - -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 (make-posn 0 0) false)) - -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 0) 'playing 1 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 0) 'playing 1 false false)) - -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 (make-posn 0 0) false) - (make-posn 0 0)) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 false false)) -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-won 1 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-won 1 false false)) -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-lost 1 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-lost 1 false false)) - -;; move-cat : world -> world -(define (move-cat world) - (local [(define cat-position (world-cat world)) - (define table (build-bfs-table world 'boundary)) - (define neighbors (adjacent cat-position (world-size world))) - (define next-cat-positions - (find-best-positions neighbors - (map (lambda (p) (lookup-in-table table p)) - neighbors))) - (define next-cat-position - (cond - [(boolean? next-cat-positions) false] - [else - (list-ref next-cat-positions - (random (length next-cat-positions)))]))] - (make-world (world-board world) - (cond - [(boolean? next-cat-position) - cat-position] - [else next-cat-position]) - (cond - [(boolean? next-cat-position) - 'cat-lost] - [(on-boundary? next-cat-position (world-size world)) - 'cat-won] - [else 'playing]) - (world-size world) - (world-mouse-posn world) - (world-h-down? world)))) - - -(check-expect - (move-cat - (make-world (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 3 0) false) - (make-cell (make-posn 4 0) false) - - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 3 1) false) - (make-cell (make-posn 4 1) false) - - (make-cell (make-posn 0 2) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) false) - (make-cell (make-posn 3 2) true) - (make-cell (make-posn 4 2) false) - - (make-cell (make-posn 0 3) false) - (make-cell (make-posn 1 3) true) - (make-cell (make-posn 2 3) false) - (make-cell (make-posn 3 3) false) - (make-cell (make-posn 4 3) false) - - (make-cell (make-posn 1 4) false) - (make-cell (make-posn 2 4) false) - (make-cell (make-posn 3 4) false) - (make-cell (make-posn 4 4) false)) - (make-posn 2 2) - 'playing - 5 - (make-posn 0 0) - false)) - (make-world (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 3 0) false) - (make-cell (make-posn 4 0) false) - - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 3 1) false) - (make-cell (make-posn 4 1) false) - - (make-cell (make-posn 0 2) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) false) - (make-cell (make-posn 3 2) true) - (make-cell (make-posn 4 2) false) - - (make-cell (make-posn 0 3) false) - (make-cell (make-posn 1 3) true) - (make-cell (make-posn 2 3) false) - (make-cell (make-posn 3 3) false) - (make-cell (make-posn 4 3) false) - - (make-cell (make-posn 1 4) false) - (make-cell (make-posn 2 4) false) - (make-cell (make-posn 3 4) false) - (make-cell (make-posn 4 4) false)) - (make-posn 2 3) - 'playing - 5 - (make-posn 0 0) - false)) - -;; find-best-positions : (nelistof posn) (nelistof number or '∞) -> (nelistof posn) or false -(define (find-best-positions posns scores) - (local [(define best-score (foldl (lambda (x sofar) - (if (<=/f x sofar) - x - sofar)) - (first scores) - (rest scores)))] - (cond - [(symbol? best-score) false] - [else - (map - second - (filter (lambda (x) (equal? (first x) best-score)) - (map list scores posns)))]))) -(check-expect (find-best-positions (list (make-posn 0 0)) (list 1)) - (list (make-posn 0 0))) -(check-expect (find-best-positions (list (make-posn 0 0)) (list '∞)) - false) -(check-expect (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list 1 2)) - (list (make-posn 0 0))) -(check-expect (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list 1 1)) - (list (make-posn 0 0) - (make-posn 1 1))) -(check-expect (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list '∞ 2)) - (list (make-posn 1 1))) -(check-expect (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list '∞ '∞)) - false) - -;; add-obstacle : board number number -> board -(define (add-obstacle board x y) - (cond - [(empty? board) board] - [else - (local [(define cell (first board)) - (define cx (cell-center-x (cell-p cell))) - (define cy (cell-center-y (cell-p cell)))] - (cond - [(and (<= (- cx circle-radius) x (+ cx circle-radius)) - (<= (- cy circle-radius) y (+ cy circle-radius))) - (cons (make-cell (cell-p cell) true) - (rest board))] - [else - (cons cell (add-obstacle (rest board) x y))]))])) - -(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false)) - circle-spacing circle-spacing) - (list (make-cell (make-posn 0 0) true))) -(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false)) 100 100) - (list (make-cell (make-posn 0 0) false))) -(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) - circle-spacing circle-spacing) - (list (make-cell (make-posn 0 0) true) - (make-cell (make-posn 0 1) false))) - -;; circle-at-point : board number number -> posn-or-false -;; returns the posn corresponding to cell where the x,y coordinates are -(define (circle-at-point board x y) - (cond - [(empty? board) false] - [else - (cond - [(point-in-this-circle? (cell-p (first board)) x y) - (cell-p (first board))] - [else - (circle-at-point (rest board) x y)])])) -(check-expect (circle-at-point empty 0 0) false) -(check-expect (circle-at-point (list (make-cell (make-posn 0 0) false)) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - (make-posn 0 0)) -(check-expect (circle-at-point (list (make-cell (make-posn 0 0) false)) - 0 0) - false) - - -;; point-in-a-circle? : board number number -> boolean -(define (point-in-a-circle? board x y) - (posn? (circle-at-point board x y))) -(check-expect (point-in-a-circle? empty 0 0) false) -(check-expect (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - true) -(check-expect (point-in-a-circle? (list (make-cell (make-posn 0 0) false)) - 0 0) - false) - -;; point-in-this-circle? : posn number number -> boolean -(define (point-in-this-circle? p x y) - (local [(define center (+ (cell-center-x p) - (* (sqrt -1) (cell-center-y p)))) - (define p2 (+ x (* (sqrt -1) y)))] - (<= (magnitude (- center p2)) circle-radius))) - -(check-expect (point-in-this-circle? (make-posn 0 0) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - true) -(check-expect (point-in-this-circle? (make-posn 0 0) 0 0) - false) - -;; change : world key-event -> world -(define (change w ke) - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - (world-mouse-posn w) - (key=? ke #\h))) - -(check-expect (change (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false) - #\h) - (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) true)) -(check-expect (change (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) true) - 'release) - (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false)) - - - - -; -; -; -; -; -; ;;;; -; ;;; -; ;;; ; -; ;;;;;; ;;;; ;;;;;;;;;;; -; ;;; ;;;; ;;;;;;;;; ;;; ;; -; ;;; ;;;;;;;;;;;;;;; ;;; -; ;;; ;;;;;;; ;;; ;;; ;;;; -; ;;; ;; ;;;; ;;; ;;;;; -; ;;; ; ;;;;;;;;;; ;;; ;;;; -; ;;; ; ;;;;;;;;;;; ;;; ;; -; ;;;; ;;;;; ;;;;; -; -; -; - - -;; cat : symbol -> image -(define (cat mode) - (local [(define face-color - (cond - [(symbol=? mode 'sad) 'pink] - [else 'lightgray])) - - (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3))) - (define right-ear (regular-polygon 3 8 'solid 'black 0)) - (define ear-x-offset 14) - (define ear-y-offset 9) - - (define eye (overlay (ellipse 12 8 'solid 'black) - (ellipse 6 4 'solid 'limegreen))) - (define eye-x-offset 8) - (define eye-y-offset 3) - - (define nose (regular-polygon 3 5 'solid 'black (/ pi 2))) - - (define mouth-happy - (overlay (ellipse 8 8 'solid face-color) - (ellipse 8 8 'outline 'black) - (move-pinhole - (rectangle 10 5 'solid face-color) - 0 - 4))) - (define mouth-no-expression - (overlay (ellipse 8 8 'solid face-color) - (ellipse 8 8 'outline face-color) - (rectangle 10 5 'solid face-color))) - - (define mouth - (cond - [(symbol=? mode 'happy) mouth-happy] - [else mouth-no-expression])) - (define mouth-x-offset 4) - (define mouth-y-offset -5)] - - (add-line - (add-line - (add-line - (add-line - (add-line - (add-line - (overlay (move-pinhole left-ear (- ear-x-offset) ear-y-offset) - (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) - (ellipse 40 26 'solid 'black) - (ellipse 36 22 'solid face-color) - (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) - (move-pinhole mouth mouth-x-offset mouth-y-offset) - (move-pinhole eye (- eye-x-offset) eye-y-offset) - (move-pinhole eye eye-x-offset eye-y-offset) - (move-pinhole nose -1 -4)) - 6 4 30 12 'black) - 6 4 30 4 'black) - 6 4 30 -4 'black) - -6 4 -30 12 'black) - -6 4 -30 4 'black) - -6 4 -30 -4 'black))) - -(define happy-cat (cat 'happy)) -(define sad-cat (cat 'sad)) -(define thinking-cat (cat 'thinking)) - - -; -; -; -; -; -; ;;;; ;;;; ;;;; ;;;; ;;;;; -; ;;;;; ;;;;; ;;; ;;;;; ;;; -; ;;; ; ;;; -; ;;;;;; ;; ; ;;;;;;;;; ; ;;;; ;; ;;; -; ;;;;; ;;; ;;;; ;;;;; ;;; ;;;;;;; ;;;;;;;;; ;;; -; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; -; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;; ;;;; ;; -; ;;;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;;;;;;;; ;;; -; ;;;;;;;;;; ;;; ;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;; -; ;;;; ;;;;; ;;;;; -; ;;; -; -; -; -; -; -; -; -; ;;;;; ;; -; ;;;; ;;;; -; ;;; ;;; -; ;;; ;;; ;;;;; ;;;; ;; ; ;;;; ;;; ;;; -; ;;;;;;;; ;;;;;;; ;;;;;;;;;;;;;;; ;;;; ;;;;;;;; -; ;;;;;;;; ;;;;;;;; ;;;;;;;;;; ;;; ;;;;;;;;;;;;;; -; ;;; ;; ;; ; ;;; ;;; ;;; ;;;; ;;; ;;; -; ;;; ;; ; ;; ;; ;;;; ;;; ;; ;;;; -; ;;;;;;; ;;;;;;;; ;;;;;;;;;; ;;; ;;;;;;;; -; ;;;;;;; ;;;;;; ;;;;;;;;;;;;;;;;;; ;;;;;;;;; -; ;;;; ;;;;; -; -; -; - -;; append-all : (listof (list X)) -> (listof X) -(define (append-all ls) - (foldr append empty ls)) - -(check-expect (append-all empty) empty) -(check-expect (append-all (list (list 1 2 3))) (list 1 2 3)) -(check-expect (append-all (list (list 1) (list 2) (list 3))) - (list 1 2 3)) - -;; add-n-random-blocked-cells : number (listof cell) number -> (listof cell) -(define (add-n-random-blocked-cells n all-cells board-size) - (cond - [(zero? n) all-cells] - [else - (local [(define unblocked-cells - (filter (lambda (x) - (let ([cat-cell? (and (= (posn-x (cell-p x)) (quotient board-size 2)) - (= (posn-y (cell-p x)) (quotient board-size 2)))]) - - (and (not (cell-blocked? x)) - (not cat-cell?)))) - all-cells)) - (define to-block (list-ref unblocked-cells - (random (length unblocked-cells))))] - (add-n-random-blocked-cells - (sub1 n) - (block-cell (cell-p to-block) all-cells) - board-size))])) - -;; block-cell : posn board -> board -(define (block-cell to-block board) - (map (lambda (c) (if (equal? to-block (cell-p c)) - (make-cell to-block true) - c)) - board)) -(check-expect (block-cell (make-posn 1 1) - (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 2) false))) - (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 2) false))) - -(check-expect (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) true)) 10) - (list (make-cell (make-posn 0 0) true))) -(check-expect (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) false)) 10) - (list (make-cell (make-posn 0 0) true))) - -;; empty-board : number -> (listof cell) -(define (empty-board board-size) - (filter - (lambda (c) - (not (and (= 0 (posn-x (cell-p c))) - (or (= 0 (posn-y (cell-p c))) - (= (- board-size 1) - (posn-y (cell-p c))))))) - (append-all - (build-list - board-size - (lambda (i) - (build-list - board-size - (lambda (j) - (make-cell (make-posn i j) - false)))))))) - -(check-expect (empty-board 3) - (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false))) - -;; empty-world : number -> world -(define (empty-world board-size) - (make-world (empty-board board-size) - (make-posn (quotient board-size 2) - (quotient board-size 2)) - 'playing - board-size - (make-posn 0 0) - false)) - -(check-expect (empty-world 3) - (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false)) - -(define dummy - (local - [(define board-size 11) - (define initial-board - (add-n-random-blocked-cells - 6 - (empty-board board-size) - board-size)) - (define initial-world - (make-world initial-board - (make-posn (quotient board-size 2) - (quotient board-size 2)) - 'playing - board-size - false - false))] - - (and - (big-bang (world-width board-size) - (world-height board-size) - 1 - initial-world) - (on-redraw render-world) - (on-key-event change) - (on-mouse-event clack)))) From b2c6dd5b9ea503808ead37b099c20f18000e7f2a Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 21 Feb 2009 18:59:25 +0000 Subject: [PATCH 073/142] This should have been a reference to the already verified contract. svn: r13780 --- collects/scheme/private/contract.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 0b122dccae..26b6ed81a7 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -607,7 +607,7 @@ improve method arity mismatch contract violation error messages? (define-syntaxes (u ... p ...) (values (make-rename-transformer #'marked-u) ... (make-with-contract-transformer - (quote-syntax ctc) + (quote-syntax ctc-id) (quote-syntax marked-p) (quote-syntax blame-stx)) ...)))))))] [(_ #:type type blame (arg ...) #:freevar x c . body) From 8a6804c52552f8100d3cf17432ee3486f621f49e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 21 Feb 2009 19:03:49 +0000 Subject: [PATCH 074/142] Need to use the srcinfo for the marked identifiers, not the unmarked ones. If this is wrong, then we need to do the first-order checks after creating the set! transformers. svn: r13781 --- collects/scheme/private/contract.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 26b6ed81a7..7c631d9be0 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -569,7 +569,7 @@ improve method arity mismatch contract violation error messages? [(ctc ...) (map marker protections)] [(p ...) protected] [(marked-p ...) (map marker protected)] - [(src-info ...) (map id->contract-src-info protected)] + [(src-info ...) (map (compose id->contract-src-info marker) protected)] [(u ...) unprotected] [(marked-u ...) (map marker unprotected)]) (quasisyntax/loc stx From f3d63b8bae72df26cbb94626692bb756260bc9d0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 21 Feb 2009 21:54:21 +0000 Subject: [PATCH 075/142] changed a C++ comment to a C comment svn: r13783 --- src/mzscheme/src/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 4d586e26d9..c8b49b92b3 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -6442,7 +6442,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, if (!SCHEME_STX_SYMBOLP(var)) scheme_wrong_syntax(NULL, var, first, "name must be an identifier"); - // scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); + /* scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); */ vars = SCHEME_STX_CDR(vars); cnt++; } From 2583ddbd58191eb583712e674ef87586e640bf6a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 21 Feb 2009 22:01:36 +0000 Subject: [PATCH 076/142] stxclass: added this-syntax, removed uses of basic stxclasses svn: r13784 --- collects/stxclass/main.ss | 2 + collects/stxclass/private/codegen.ss | 26 +-- collects/stxclass/private/debug.ss | 15 ++ collects/stxclass/private/lib.ss | 232 ++++++++++----------------- collects/stxclass/private/rep.ss | 25 ++- collects/stxclass/private/runtime.ss | 8 + collects/stxclass/private/sc.ss | 3 +- collects/stxclass/util/misc.ss | 8 +- 8 files changed, 153 insertions(+), 166 deletions(-) create mode 100644 collects/stxclass/private/debug.ss diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss index b8e06462a2..f55c6ba21a 100644 --- a/collects/stxclass/main.ss +++ b/collects/stxclass/main.ss @@ -17,6 +17,8 @@ with-patterns attribute + this-syntax + current-expression current-macro-name diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index 7d9d458f03..81727b614f 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -14,7 +14,10 @@ "../util.ss") (provide/contract [parse:rhs (rhs? (listof sattr?) (listof identifier?) . -> . syntax?)] - [parse:clauses (syntax? identifier? identifier? . -> . syntax?)]) + [parse:clauses (syntax? identifier? identifier? . -> . syntax?)] + [announce-failures? parameter?]) + +(define announce-failures? (make-parameter #f)) ;; parse:rhs : RHS (listof SAttr) (listof identifier) -> stx ;; Takes a list of the relevant attrs; order is significant! @@ -27,15 +30,16 @@ #,(if (rhs-transparent? rhs) #`(make-failed x expected frontier frontier-stx) #'#f)) - #,(let ([pks (rhs->pks rhs relsattrs #'x)]) - (unless (pair? pks) - (wrong-syntax (rhs-orig-stx rhs) - "syntax class has no variants")) - (parse:pks (list #'x) - (list (empty-frontier #'x)) - #'fail-rhs - (list #f) - pks))))] + (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) + #,(let ([pks (rhs->pks rhs relsattrs #'x)]) + (unless (pair? pks) + (wrong-syntax (rhs-orig-stx rhs) + "syntax class has no variants")) + (parse:pks (list #'x) + (list (empty-frontier #'x)) + #'fail-rhs + (list #f) + pks)))))] [(rhs:basic? rhs) (rhs:basic-parser rhs)])) @@ -140,6 +144,8 @@ [fstx-expr (frontier->fstx-expr fce)]) #`(let ([failcontext fc-expr] [failcontext-syntax fstx-expr]) + #,(when (announce-failures?) + #`(printf "failing on ~s\n reason: ~s\n" x p)) (k x p failcontext failcontext-syntax)))) ;; Parsing diff --git a/collects/stxclass/private/debug.ss b/collects/stxclass/private/debug.ss new file mode 100644 index 0000000000..670ba1eb8f --- /dev/null +++ b/collects/stxclass/private/debug.ss @@ -0,0 +1,15 @@ + +#lang scheme/base +(require (for-syntax scheme/base) + (for-syntax "codegen.ss")) + +(provide announce-parse-failures) + +(define-syntax (announce-parse-failures stx) + (syntax-case stx () + [(_ b) + (begin (announce-failures? (and (syntax-e #'b) #t)) + #'(void))] + [(_) + #'(announce-failures #t)])) + diff --git a/collects/stxclass/private/lib.ss b/collects/stxclass/private/lib.ss index 6497a307e4..5f2906f1f7 100644 --- a/collects/stxclass/private/lib.ss +++ b/collects/stxclass/private/lib.ss @@ -13,13 +13,10 @@ (provide (all-defined-out)) (define-syntax-rule (define-pred-stxclass name pred) - (define-basic-syntax-class name - ([datum 0]) - (lambda (x) - (let ([d (if (syntax? x) (syntax-e x) x)]) - (if (pred d) - (list d) - #f))))) + (define-syntax-class name #:attributes ([datum 0]) + (pattern x + #:with datum (if (syntax? #'x) (syntax-e #'x) #'x) + #:when (pred (attribute datum))))) (define-pred-stxclass identifier symbol?) (define-pred-stxclass boolean boolean?) @@ -33,160 +30,105 @@ (define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?) (define-pred-stxclass exact-positive-integer exact-positive-integer?) -(define-syntax-rule (define-kw-stxclass name kw) - (define-basic-syntax-class name - () - (lambda (x) - (if (and (identifier? x) (free-identifier=? x (quote-syntax kw))) - null - #f)))) - -(define-kw-stxclass lambda-kw #%lambda) -(define-kw-stxclass define-values-kw define-values) -(define-kw-stxclass define-syntaxes-kw define-syntaxes) - -(define-syntax-class define-values-form - (pattern (kw:define-values-kw (var:identifier ...) rhs))) -(define-syntax-class define-syntaxes-form - (pattern (kw:define-syntaxes-kw (var:identifier ...) rhs))) -(define-syntax-class definition-form - (pattern :define-values-form) - (pattern :define-syntaxes-form)) - (define-syntax-class (static-of name pred) - #:description name - #:attributes ([value 0]) - (basic-syntax-class - (lambda (x name pred) - (let/ec escape - (define (bad) (escape #f)) - (if (identifier? x) - (let ([value (syntax-local-value x bad)]) - (unless (pred value) (bad)) - (list value)) - (bad)))))) - -(define-syntax-class static #:attributes (value) + (pattern x:id + #:with value-list (syntax-local-value* #'x) + #:when (pair? (attribute value-list)) + #:with value (car (attribute value-list)) + #:when (pred (attribute value)))) + +(define (syntax-local-value* id) + (let/ec escape + (list (syntax-local-value id (lambda () (escape null)))))) + +(define-syntax-class static #:attributes (value) (pattern x #:declare x (static-of "static" (lambda _ #t)) #:with value #'x.value)) -(define-basic-syntax-class struct-name - ([descriptor 0] - [constructor 0] - [predicate 0] - [accessor 1] - [super 0] - [complete? 0]) - (lambda (x) - (if (identifier? x) - (let/ec escape - (define (bad) (escape #f)) - (let ([value (syntax-local-value x bad)]) - (unless (struct-info? value) (bad)) - (let ([lst (extract-struct-info value)]) - (let ([descriptor (list-ref lst 0)] - [constructor (list-ref lst 1)] - [predicate (list-ref lst 2)] - [accessors (list-ref lst 3)] - [super (list-ref lst 5)]) - (let ([r-accessors (reverse accessors)]) - (list descriptor - constructor - predicate - (if (and (pair? r-accessors) - (eq? #f (car r-accessors))) - (cdr r-accessors) - r-accessors) - super - (or (null? r-accessors) - (not (eq? #f (car r-accessors)))))))))) - #f))) +(define-syntax-class struct-name + #:description "struct name" + #:attributes (descriptor + constructor + predicate + [accessor 1] + super + complete?) + (pattern s + #:declare s (static-of "struct name" struct-info?) + #:with info (extract-struct-info (attribute s.value)) + #:with descriptor (list-ref (attribute info) 0) + #:with constructor (list-ref (attribute info) 1) + #:with predicate (list-ref (attribute info) 2) + #:with r-accessors (reverse (list-ref (attribute info) 3)) + #:with (accessor ...) + (datum->syntax #f (let ([r-accessors (attribute r-accessors)]) + (if (and (pair? r-accessors) (eq? #f (car r-accessors))) + (cdr r-accessors) + r-accessors))) + #:with super (list-ref (attribute info) 5) + #:with complete? (or (null? (attribute r-accessors)) + (and (pair? (attribute r-accessors)) + (not (eq? #f (car (attribute r-accessors)))))))) -(define-basic-syntax-class expr/local-expand - ([expanded 0]) - (lambda (x) - (list (local-expand x 'expression null)))) +(define-syntax-class expr/local-expand + #:attributes (expanded) + (pattern x + #:with expanded (local-expand #'x 'expression null))) -(define-basic-syntax-class expr/head-local-expand - ([expanded 0]) - (lambda (x) - (list (local-expand x 'expression (kernel-form-identifier-list))))) +(define-syntax-class expr/head-local-expand + #:attributes (expanded) + (pattern x + #:with expanded (local-expand #'x 'expression (kernel-form-identifier-list)))) -(define-basic-syntax-class block/head-local-expand - ([expanded-block 0] - [expanded 1] - [def 1] - [vdef 1] - [sdef 1] - [expr 1]) - (lambda (x) - (let-values ([(ex1 ex2 defs vdefs sdefs exprs) - (head-local-expand-and-categorize-syntaxes x #f #; #t)]) - (list ex1 ex2 defs vdefs sdefs exprs)))) +(define-syntax-class block/head-local-expand + #:attributes (expanded-block + [expanded 1] + [def 1] + [vdef 1] + [sdef 1] + [expr 1]) + (pattern x + #:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...)) + (datum->syntax #f + (let-values ([(ex1 ex2 defs vdefs sdefs exprs) + (head-local-expand-and-categorize-syntaxes + #'x #f #| #t |#)]) + (list ex1 ex2 defs vdefs sdefs exprs))))) -(define-basic-syntax-class internal-definitions - ([expanded-block 0] - [expanded 1] - [def 1] - [vdef 1] - [sdef 1] - [expr 1]) - (lambda (x) - (let-values ([(ex1 ex2 defs vdefs sdefs exprs) - (head-local-expand-and-categorize-syntaxes x #t #; #f)]) - (list ex1 ex2 defs vdefs sdefs exprs)))) +(define-syntax-class internal-definitions + #:attributes (expanded-block + [expanded 1] + [def 1] + [vdef 1] + [sdef 1] + [expr 1]) + (pattern x + #:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...)) + (datum->syntax #f + (let-values ([(ex1 ex2 defs vdefs sdefs exprs) + (head-local-expand-and-categorize-syntaxes + #'x #t #| #f |#)]) + (list ex1 ex2 defs vdefs sdefs exprs))))) -(define-syntax-rule (define-contract-stxclass name c) - (define-basic-syntax-class* (name) - ([orig-stx 0]) - (lambda (x) - (list #`(contract c - #,x - (quote #,(string->symbol (or (build-src-loc-string x) ""))) - (quote #,(or (current-macro-name) ')) - (quote-syntax #,(syntax/loc x ()))) - x)))) +(define-syntax-class expr + #:attributes () + (pattern x + #:when (and (syntax? #'x) (not (keyword? (syntax-e #'x)))))) -(define-contract-stxclass expr/num number?) -(define-contract-stxclass expr/num->num (-> number? number?)) - -(define-basic-syntax-class* (expr) - () - (lambda (x) - (if (not (keyword? (syntax-e x))) - (list x) - #f))) ;; FIXME: hack (define expr/c-use-contracts? (make-parameter #t)) -(define-basic-syntax-class* (expr/c contract) - ([orig-stx 0]) - (lambda (x c) - (if (not (keyword? (syntax-e x))) - (if (expr/c-use-contracts?) - (list #`(contract #,c - #,x - (quote #,(string->symbol - (or (build-src-loc-string x) ""))) - (quote #,(or (current-macro-name) ')) - (quote-syntax #,(syntax/loc x ()))) - x) - (list x x)) - #f))) - -(define-basic-syntax-class (term parser) - () - (lambda (x p) (p x))) - -(define-basic-syntax-class (term/pred pred) - () - (lambda (x p) - (if (p x) - null - #f))) +(define-syntax-class (expr/c ctc) + #:attributes (c) + (pattern x:expr + #:with c #`(contract #,ctc + x + (quote #,(string->symbol (or (build-src-loc-string #'x) ""))) + (quote #,(or (current-macro-name) ')) + (quote-syntax #,(syntax/loc #'x ()))))) ;; Aliases diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index 6eaf1a90a9..dd96ade8d5 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -281,21 +281,20 @@ [(struct pattern (orig-stx iattrs depth)) (make head orig-stx iattrs depth (list p) #f #f #t)])) -(define head-directive-table - (list (list '#:min check-nat/f) - (list '#:max check-nat/f) - (list '#:opt) - (list '#:mand))) - (define (parse-heads stx decls enclosing-depth) (syntax-case stx () [({} . more) (wrong-syntax (stx-car stx) "empty head sequence not allowed")] [({p ...} . more) - (let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)]) + (let() + (define-values (chunks rest) + (chunk-kw-seq/no-dups #'more head-directive-table)) + (define-values (chunks2 rest2) + (chunk-kw-seq rest head-directive-table2)) + ;; FIXME FIXME: handle chunks2 !!!! (cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks) - (parse-heads rest decls enclosing-depth)))] + (parse-heads rest2 decls enclosing-depth)))] [() null] [_ @@ -483,3 +482,13 @@ ;; and-pattern-directive-table (define and-pattern-directive-table (list (list '#:description check-lit-string))) + +(define head-directive-table + (list (list '#:min check-nat/f) + (list '#:max check-nat/f) + (list '#:opt) + (list '#:mand))) + +(define head-directive-table2 + (list (list '#:with values values) + (list '#:declare check-id values))) diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss index df7c7cc61a..22a3bdaaad 100644 --- a/collects/stxclass/private/runtime.ss +++ b/collects/stxclass/private/runtime.ss @@ -22,6 +22,8 @@ current-expression current-macro-name + this-syntax + (for-syntax expectation-of-stxclass expectation-of-constants expectation-of/message) @@ -62,6 +64,12 @@ (lambda (stx) (wrong-syntax stx "used out of context: not parsing pattern"))) +;; this-syntax +;; Bound to syntax being matched inside of syntax class +(define-syntax-parameter this-syntax + (lambda (stx) + (wrong-syntax stx "used out of context: not within a syntax class"))) + (define current-expression (make-parameter #f)) (define (current-macro-name) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 7e5d702c9f..1f9e10b039 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -1,4 +1,3 @@ - #lang scheme/base (require (for-syntax scheme/base scheme/match @@ -32,6 +31,8 @@ (struct-out failed) + this-syntax + current-expression current-macro-name) diff --git a/collects/stxclass/util/misc.ss b/collects/stxclass/util/misc.ss index 13aba13abc..17fb4f9f08 100644 --- a/collects/stxclass/util/misc.ss +++ b/collects/stxclass/util/misc.ss @@ -14,6 +14,7 @@ with-catching-disappeared-uses with-disappeared-uses syntax-local-value/catch + record-disappeared-uses format-symbol @@ -51,10 +52,13 @@ (define (syntax-local-value/catch id pred) (let ([value (syntax-local-value id (lambda () #f))]) (and (pred value) - (begin (let ([uses (current-caught-disappeared-uses)]) - (when uses (current-caught-disappeared-uses (cons id uses)))) + (begin (record-disappeared-uses (list id)) value)))) +(define (record-disappeared-uses ids) + (let ([uses (current-caught-disappeared-uses)]) + (when uses + (current-caught-disappeared-uses (append ids uses))))) ;; Generating temporaries From 6777df63df9b0f6905c09381e897ad810a6036f7 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sun, 22 Feb 2009 03:31:35 +0000 Subject: [PATCH 077/142] add examples for require forms svn: r13787 --- collects/scribblings/reference/syntax.scrbl | 183 +++++++++++++++++--- 1 file changed, 163 insertions(+), 20 deletions(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index a246ed8739..fea3da084c 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -421,7 +421,27 @@ pre-defined forms are as follows. @scheme[require-spec]s, but constrained each binding specified by each @scheme[require-spec] is shifted by @scheme[phase-level]. The @tech{label phase level} corresponds to @scheme[#f], and a shifting - combination that involves @scheme[#f] produces @scheme[#f].} + combination that involves @scheme[#f] produces @scheme[#f]. + + @defexamples[#:eval (syntax-eval) + (module test scheme + (provide foo) + (define foo 2)) + (require (for-meta 0 'test)) + foo + ]} + + @defexamples[#:eval (syntax-eval) + (module test scheme + (provide foo) + (define foo 2)) + (require (for-meta 1 'test)) + (define-syntax bar + (lambda (stx) + (printf "~a\n" foo) + #'1)) + (bar) + ]} @specsubform[#:literals (for-syntax) (for-syntax require-spec ...)]{Same as @@ -451,7 +471,10 @@ corresponds to the default @tech{module name resolver}. @specsubform[#:literals (quote) (#,(scheme quote) id)]{ Refers to a module previously declared interactively with the name - @scheme[id].} + @scheme[id]. + + Example: Require'ing a module named test. + @scheme[(require 'test)]} @specsubform[rel-string]{A path relative to the containing source (as determined by @scheme[current-load-relative-directory] or @@ -473,7 +496,15 @@ corresponds to the default @tech{module name resolver}. @margin-note{The @litchar{%} provision is intended to support a one-to-one encoding of arbitrary strings as path elements (after UTF-8 encoding). Such encodings are not decoded to arrive at a - filename, but instead preserved in the file access.}} + filename, but instead preserved in the file access.} + + Example: Require a module named x.ss in the same directory as this file. + + @scheme[(require "x.ss")] + + Require a module named x.ss in the parent directory. + + @scheme[(require "../x.ss")]} @defsubform[(lib rel-string ...+)]{A path to a module installed into a @tech{collection} (see @secref["collects"]). The @scheme[rel-string]s in @@ -489,19 +520,31 @@ corresponds to the default @tech{module name resolver}. @item{If a single @scheme[rel-string] is provided, and if it consists of a single element (i.e., no @litchar{/}) with no file suffix (i.e., no @litchar{.}), then @scheme[rel-string] names a - @tech{collection}, and @filepath{main.ss} is the library file name.} + @tech{collection}, and @filepath{main.ss} is the library file name. + + Example: require swindle + @defexamples[#:eval (syntax-eval) + (require (lib "swindle"))]} @item{If a single @scheme[rel-string] is provided, and if it consists of multiple @litchar{/}-separated elements, then each element up to the last names a @tech{collection}, subcollection, etc., and the last element names a file. If the last element has - no file suffix, @filepath{.ss} is added.} + no file suffix, @filepath{.ss} is added. + + Example: require a file within the swindle collection + @defexamples[#:eval (syntax-eval) + (require (lib "swindle/turbo"))]} @item{If a single @scheme[rel-string] is provided, and if it consists of a single element @italic{with} a file suffix (i.e, with a @litchar{.}), then @scheme[rel-string] names a file within the @filepath{mzlib} @tech{collection}. (This convention is for - compatibility with older version of PLT Scheme.)} + compatibility with older version of PLT Scheme.) + + Example: require the tar module from mzlib + @defexamples[#:eval (syntax-eval) + (require (lib "tar.ss"))]} @item{Otherwise, when multiple @scheme[rel-string]s are provided, the first @scheme[rel-string] is effectively moved after the @@ -509,18 +552,26 @@ corresponds to the default @tech{module name resolver}. separators. The resulting path names a @tech{collection}, then subcollection, etc., ending with a file name. No suffix is added automatically. (This convention is for compatibility - with older version of PLT Scheme.)} + with older version of PLT Scheme.) + Example: require the tar module from mzlib + @defexamples[#:eval (syntax-eval) + (require (lib "tar.ss" "mzlib"))]} }} @specsubform[id]{A shorthand for a @scheme[lib] form with a single @scheme[_rel-string] whose characters are the same as in the symbolic form of @scheme[id]. In addition to the constraints of a @scheme[lib] - @scheme[_rel-string], @scheme[id] must not contain @litchar{.}.} + @scheme[_rel-string], @scheme[id] must not contain @litchar{.}. + + @defexamples[#:eval (syntax-eval) + (require scheme/tcp)]} @defsubform[(file string)]{Similar to the plain @scheme[rel-string] case, but @scheme[string] is a path---possibly absolute---using the - current platform's path conventions and @scheme[expand-user-path].} + current platform's path conventions and @scheme[expand-user-path]. + + @scheme[(require (file "~/tmp/x.ss"))]} @defsubform*[((planet id) (planet string) @@ -578,7 +629,23 @@ corresponds to the default @tech{module name resolver}. @scheme[((unsyntax (schemeidfont "-")) _nat)] specifies a maximum version. The @schemeidfont{=}, @schemeidfont{+}, and @schemeidfont{-} identifiers in a minor-version constraint are recognized - symbolically.} + symbolically. + + Example: Load main.ss file package foo owned by bar. + + @scheme[(require (planet bar/foo))] + + Example: Load major version 2 of main.ss file package foo owned by bar. + + @scheme[(require (planet bar/foo:2))] + + Example: Load major version 2 and minor version 5 of main.ss file package foo owned by bar. + + @scheme[(require (planet bar/foo:2:5))] + + Example: Load major version 2 and minor version 5 of buz.ss file package foo owned by bar. + + @scheme[(require (planet bar/foo:2:5/buz))]} No identifier can be bound multiple times in a given @tech{phase level} by an import, unless all of the bindings refer to the same @@ -627,7 +694,15 @@ follows. @tech{phase level}. The symbolic form of @scheme[id] is used as the external name, and the symbolic form of the defined or imported identifier must match (otherwise, the external name could be - ambiguous). } + ambiguous). + + @defexamples[#:eval (syntax-eval) + (module test scheme + (provide foo) + (define foo 2)) + (require 'test) + foo + ]} @defsubform[(all-defined-out)]{ Exports all identifiers that are defined at @tech{phase level} 0 or @tech{phase level} 1 within the @@ -637,7 +712,15 @@ follows. accessible from the lexical context of the @scheme[(all-defined-out)] form are included; that is, macro-introduced imports are not re-exported, unless the @scheme[(all-defined-out)] form was - introduced at the same time.} + introduced at the same time. + + @defexamples[#:eval (syntax-eval) + (module test scheme + (provide (all-defined-out)) + (define foo 2)) + (require 'test) + foo + ]} @defsubform[(all-from-out module-path ...)]{ Exports all identifiers that are imported into the exporting module using a @@ -648,23 +731,62 @@ follows. @scheme[module-path]. Only identifiers accessible from the lexical context of the @scheme[module-path] are included; that is, macro-introduced imports are not re-exported, unless the - @scheme[module-path] was introduced at the same time.} + @scheme[module-path] was introduced at the same time. + + @defexamples[#:eval (syntax-eval) + (module a scheme + (provide foo) + (define foo 2)) + (module b scheme + (require 'a) + (provide (all-from-out 'a))) + (require 'b) + foo + ]} @defsubform[(rename-out [orig-id export-id] ...)]{ Exports each @scheme[orig-id], which must be @tech{bound} within the module at @tech{phase level} 0. The symbolic name for each export is - @scheme[export-id] instead @scheme[orig-d].} + @scheme[export-id] instead @scheme[orig-d]. + + @defexamples[#:eval (syntax-eval) + (module a scheme + (provide (rename-out (foo myfoo))) + (define foo 2)) + (require 'a) + foo + myfoo + ]} @defsubform[(except-out provide-spec provide-spec ...)]{ Like the first @scheme[provide-spec], but omitting the bindings listed in each subsequent @scheme[provide-spec]. If one of the latter bindings is not included in the initial @scheme[provide-spec], a syntax error is reported. The symbolic export name information in the latter - @scheme[provide-spec]s is ignored; only the bindings are used.} + @scheme[provide-spec]s is ignored; only the bindings are used. + + @defexamples[#:eval (syntax-eval) + (module a scheme + (provide (except-out (all-defined-out) + bar)) + (define foo 2) + (define bar 3)) + (require 'a) + foo + bar + ]} @defsubform[(prefix-out prefix-id provide-spec)]{ Like @scheme[provide-spec], but with each symbolic export name from - @scheme[provide-spec] prefixed with @scheme[prefix-id].} + @scheme[provide-spec] prefixed with @scheme[prefix-id]. + + @defexamples[#:eval (syntax-eval) + (module a scheme + (provide (prefix-out f foo)) + (define foo 2)) + (require 'a) + f:foo + ]} @defsubform[(struct-out id)]{Exports the bindings associated with a structure type @scheme[id]. Typically, @scheme[id] is bound with @@ -678,10 +800,32 @@ follows. includes a super-type identifier, and if the identifier has a @tech{transformer binding} of structure-type information, the accessor and mutator bindings of the super-type are @italic{not} - included by @scheme[struct-out] for export.} + included by @scheme[struct-out] for export. + + @defexamples[#:eval (syntax-eval) + (module a scheme + (provide (struct-out foo)) + (define-struct foo (a b c))) + (require 'a) + make-foo + foo-a + foo-b + foo-c + foo? + ]} @defsubform[(combine-out provide-spec ...)]{ The union of the - @scheme[provide-spec]s.} + @scheme[provide-spec]s. + + @defexamples[#:eval (syntax-eval) + (module a scheme + (provide (combine-out foo bar)) + (define foo 2) + (define bar 1)) + (require 'a) + foo + bar + ]} @defsubform[(protect-out provide-spec ...)]{ Like the union of the @scheme[provide-spec]s, except that the exports are protected; see @@ -719,8 +863,7 @@ multiple symbolic names.} @defform[(for-meta phase-level require-spec ...)]{See @scheme[require] and @scheme[provide].} -@defform[(for-syntax require-spec ...)]{See @scheme[require] and @scheme[provide].} -@defform[(for-template require-spec ...)]{See @scheme[require] and @scheme[provide].} +@defform[(for-syntax require-spec ...)]{See @scheme[require] and @scheme[provide].} @defform[(for-template require-spec ...)]{See @scheme[require] and @scheme[provide].} @defform[(for-label require-spec ...)]{See @scheme[require] and @scheme[provide].} @defform/subs[(#%require raw-require-spec ...) From 4cbd62709ada3cbe647ad0403316681058d8cb60 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Feb 2009 08:50:19 +0000 Subject: [PATCH 078/142] Welcome to a new PLT day. svn: r13788 --- 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 75a1c0c4c6..13dcd4e295 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "21feb2009") +#lang scheme/base (provide stamp) (define stamp "22feb2009") From cdfc9ffc365bb3efdebdbdda7ccdddf59620c2c9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Feb 2009 16:00:00 +0000 Subject: [PATCH 079/142] layout improvements svn: r13790 --- collects/scribble/latex-render.ss | 8 ++++---- collects/scribble/private/manual-style.ss | 2 +- collects/scribble/scribble.tex | 3 +++ 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index e125e8fd24..30b7a7207a 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -136,7 +136,7 @@ (printf "\\label{t:~a}" (t-encode (tag-key (target-element-tag e) ri)))) (when part-label? - (printf "\\S") + (printf "\\SecRef{") (render-content (let ([dest (resolve-get part ri (link-element-tag e))]) (if dest @@ -149,7 +149,7 @@ '("!!!"))) (list "???"))) part ri) - (printf " ``")) + (printf "}{")) (let ([style (and (element? e) (let ([s (flatten-style (element-style e))]) (if (with-attributes? s) @@ -206,7 +206,7 @@ (image-file-scale style) fn)))] [else (super render-element e part ri)]))) (when part-label? - (printf "''")) + (printf "}")) (when (and (link-element? e) (show-link-page-numbers) (not (done-link-page-numbers))) @@ -308,7 +308,7 @@ (loop (cdr flowss) (cdr row-styles))))) (unless inline? (printf "~a\n\n\\end{~a}\n" - (if (equal? tableform "bigtabular") "\n\\\\" "") + "" ; (if (equal? tableform "bigtabular") "\n\\\\" "") tableform))))) null) diff --git a/collects/scribble/private/manual-style.ss b/collects/scribble/private/manual-style.ss index fe5e184d96..d4f0eba918 100644 --- a/collects/scribble/private/manual-style.ss +++ b/collects/scribble/private/manual-style.ss @@ -26,7 +26,7 @@ void-const undefined-const math) -(define PLaneT "PLaneT") +(define PLaneT (make-element "planetName" '("PLaneT"))) (define etc "etc.") ; so we can fix the latex space, one day diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index abd2ae20fd..0db7032b72 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -70,6 +70,7 @@ \newcommand{\imageleft}[1]{} % drop it \renewcommand{\smaller}[1]{\textsmaller{#1}} \newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}} +\newcommand{\planetName}[1]{PLane$\!$T} \newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle} \newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle} @@ -89,6 +90,8 @@ \newenvironment{bigtabular}{\begin{longtable}}{\end{longtable}\vspace{-3ex}} \newcommand{\bigtabline}{\vspace{-2ex}} +\newcommand{\SecRef}[2]{\S#1 ``#2''} + \newcommand{\sectionhidden}[1]{\section{#1}} \newcommand{\subsectionhidden}[1]{\subsection{#1}} \newcommand{\subsubsectionhidden}[1]{\subsubsection{#1}} From e6ee0cd001636d55e8b692a109c1c95bbbf1b23b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Feb 2009 16:01:53 +0000 Subject: [PATCH 080/142] PLaneT typesetting svn: r13791 --- collects/scribble/scribble.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index 0db7032b72..3c0552fa56 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -70,7 +70,7 @@ \newcommand{\imageleft}[1]{} % drop it \renewcommand{\smaller}[1]{\textsmaller{#1}} \newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}} -\newcommand{\planetName}[1]{PLane$\!$T} +\newcommand{\planetName}[1]{PLane\hspace{-0.1ex}T} \newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle} \newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle} From 04c2a2c3a4ab78103f6c682964ce53f675887c83 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Feb 2009 18:37:35 +0000 Subject: [PATCH 081/142] scribble back-end configuration improvements svn: r13792 --- collects/scribble/base-render.ss | 24 ++++ collects/scribble/basic.ss | 4 +- collects/scribble/html-render.ss | 27 ++-- collects/scribble/latex-render.ss | 17 ++- collects/scribble/run.ss | 5 + collects/scribble/scribble-prefix.html | 1 + collects/scribble/scribble-prefix.tex | 11 ++ collects/scribble/scribble.tex | 14 +- collects/scribble/text-render.ss | 3 +- collects/scribblings/scribble/basic.scrbl | 8 +- collects/scribblings/scribble/config.scrbl | 135 +++++++++++++++++++ collects/scribblings/scribble/how-to.scrbl | 6 +- collects/scribblings/scribble/inbox.css | 4 + collects/scribblings/scribble/inbox.tex | 2 + collects/scribblings/scribble/scribble.scrbl | 1 + collects/scribblings/scribble/struct.scrbl | 21 ++- 16 files changed, 244 insertions(+), 39 deletions(-) create mode 100644 collects/scribble/scribble-prefix.html create mode 100644 collects/scribble/scribble-prefix.tex create mode 100644 collects/scribblings/scribble/config.scrbl create mode 100644 collects/scribblings/scribble/inbox.css create mode 100644 collects/scribblings/scribble/inbox.tex diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index 0279f549ab..df0ca9e429 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -47,6 +47,30 @@ ;; ---------------------------------------- + (define/public (extract-part-style-files d tag stop-at-part?) + (let loop ([p d]) + (let ([s (part-style p)]) + (apply + append + (if (list? s) + (filter + values + (map (lambda (s) + (and (list? s) + (= 2 (length s)) + (eq? (car s) tag) + (path-string? (cadr s)) + (cadr s))) + s)) + null) + (map (lambda (p) + (if (stop-at-part? p) + null + (loop p))) + (part-parts p)))))) + + ;; ---------------------------------------- + (define root (make-mobile-root root-path)) (define-values (:path->root-relative diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index d90ae6f127..80aed345a0 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -213,8 +213,8 @@ h)) (make-element 'hspace (list (make-string n #\space))))) -(define (elem . str) - (make-element #f (decode-content str))) +(define (elem #:style [style #f] . str) + (make-element style (decode-content str))) (define (aux-elem . s) (make-aux-element #f (decode-content s))) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index e472fa42d1..542f095ec7 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -4,6 +4,7 @@ scheme/class scheme/path scheme/file + scheme/port scheme/list scheme/string mzlib/runtime-path @@ -43,6 +44,7 @@ "\n")))) (define-runtime-path scribble-css "scribble.css") +(define-runtime-path scribble-prefix-html "scribble-prefix.html") (define-runtime-path scribble-js "scribble-common.js") ;; utilities for render-one-part (define-values (scribble-css-contents scribble-js-contents) @@ -232,13 +234,15 @@ install-file get-dest-directory format-number - quiet-table-of-contents) + quiet-table-of-contents + extract-part-style-files) (init-field [css-path #f] ;; up-path is either a link "up", or #t which uses ;; goes to start page (using cookies to get to the ;; user start page) [up-path #f] + [prefix-file #f] [style-file #f] [style-extra-files null] [script-path #f] @@ -570,19 +574,19 @@ (define/public (render-one-part d ri fn number) (parameterize ([current-output-file fn]) - (let* ([style-file (or style-file scribble-css)] + (let* ([prefix-file (or prefix-file scribble-prefix-html)] + [style-file (or style-file scribble-css)] [script-file (or script-file scribble-js)] [title (cond [(part-title-content d) => (lambda (c) `(title ,@(format-number number '(nbsp)) ,(content->string c this d ri)))] [else `(title)])]) - (unless css-path (install-file style-file)) - (for-each (lambda (f) (install-file f)) style-extra-files) + (unless css-path (install-file style-file)) (unless script-path (install-file script-file)) - (printf "\n" - "-//W3C//DTD HTML 4.0 Transitional//EN" - "http://www.w3.org/TR/html4/loose.dtd") + (call-with-input-file* prefix-file + (lambda (in) + (copy-port in (current-output-port)))) (xml:write-xml/content (xml:xexpr->xml `(html () @@ -592,8 +596,13 @@ ,title ,(scribble-css-contents style-file css-path) ,@(map (lambda (style-file) - (scribble-css-contents style-file css-path)) - style-extra-files) + (install-file style-file) + (scribble-css-contents style-file #f)) + (append style-extra-files + (extract-part-style-files + d + 'css + (lambda (p) (part-whole-page? p ri))))) ,(scribble-js-contents script-file script-path)) (body () ,@(render-toc-view d ri) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 30b7a7207a..d43fcc81a9 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -17,6 +17,7 @@ (define-struct (toc-paragraph paragraph) ()) +(define-runtime-path scribble-prefix-tex "scribble-prefix.tex") (define-runtime-path scribble-tex "scribble.tex") (define (gif-to-png p) @@ -26,7 +27,8 @@ (define (render-mixin %) (class % - (init-field [style-file #f] + (init-field [prefix-file #f] + [style-file #f] [style-extra-files null]) (define/override (get-suffix) #".tex") @@ -35,16 +37,23 @@ render-block render-content install-file - format-number) + format-number + extract-part-style-files) (define/override (render-one d ri fn) - (let ([style-file (or style-file scribble-tex)]) + (let ([style-file (or style-file scribble-tex)] + [prefix-file (or prefix-file scribble-prefix-tex)]) (for-each (lambda (style-file) (with-input-from-file style-file (lambda () (copy-port (current-input-port) (current-output-port))))) - (cons style-file style-extra-files)) + (list* prefix-file style-file + (append style-extra-files + (extract-part-style-files + d + 'tex + (lambda (p) #f))))) (printf "\\begin{document}\n\\preDoc\n") (when (part-title-content d) (let ([m (ormap (lambda (v) diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss index 58bd496125..12650f8cd1 100644 --- a/collects/scribble/run.ss +++ b/collects/scribble/run.ss @@ -32,6 +32,8 @@ (make-parameter null)) (define current-xref-input-modules (make-parameter null)) + (define current-prefix-file + (make-parameter #f)) (define current-style-file (make-parameter #f)) (define current-style-extra-files @@ -67,6 +69,8 @@ (current-dest-directory dir)] [("--dest-name") name "write output as " (current-dest-name name)] + [("--prefix") file "use given .html/.tex prefix (for doctype/documentclass)" + (current-prefix-file file)] [("--style") file "use given base .css/.tex file" (current-style-file file)] [("--redirect") url "redirect external links to tag search via " @@ -110,6 +114,7 @@ (let ([renderer (new ((current-render-mixin) render%) [dest-dir dir] + [prefix-file (current-prefix-file)] [style-file (current-style-file)] [style-extra-files (reverse (current-style-extra-files))])]) (when (current-redirect) diff --git a/collects/scribble/scribble-prefix.html b/collects/scribble/scribble-prefix.html new file mode 100644 index 0000000000..4ef584cce5 --- /dev/null +++ b/collects/scribble/scribble-prefix.html @@ -0,0 +1 @@ + diff --git a/collects/scribble/scribble-prefix.tex b/collects/scribble/scribble-prefix.tex new file mode 100644 index 0000000000..9cfd09828e --- /dev/null +++ b/collects/scribble/scribble-prefix.tex @@ -0,0 +1,11 @@ +% This is the default prefix for Scribble-generated Latex +\documentclass{article} + +\parskip=10pt +\parindent=0pt + +% Adjust margins to match HTML width for +% fixed-width font +\advance \oddsidemargin by -0.15in +\advance \evensidemargin by -0.15in +\advance \textwidth by 0.3in diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index 3c0552fa56..47e3f69168 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -1,16 +1,5 @@ -% This is the default prefix for Scribble-generated Latex - -\documentclass{article} +% This is the default style configuration for Scribble-generated Latex -\parskip=10pt -\parindent=0pt - -% Adjust margins to match HTML width for -% fixed-width font -\advance \oddsidemargin by -0.15in -\advance \evensidemargin by -0.15in -\advance \textwidth by 0.3in - \usepackage{graphicx} \usepackage{hyperref} \renewcommand{\rmdefault}{ptm} @@ -88,7 +77,6 @@ \newenvironment{bibentry}[1]{\parbox[t]{0.8\linewidth}{#1}} \newenvironment{bigtabular}{\begin{longtable}}{\end{longtable}\vspace{-3ex}} -\newcommand{\bigtabline}{\vspace{-2ex}} \newcommand{\SecRef}[2]{\S#1 ``#2''} diff --git a/collects/scribble/text-render.ss b/collects/scribble/text-render.ss index 31835d1f3a..906d426dac 100644 --- a/collects/scribble/text-render.ss +++ b/collects/scribble/text-render.ss @@ -6,7 +6,8 @@ (define (render-mixin %) (class % - (init [style-file #f] + (init [prefix-file #f] + [style-file #f] [style-extra-files ()]) (define/override (get-substitutions) diff --git a/collects/scribblings/scribble/basic.scrbl b/collects/scribblings/scribble/basic.scrbl index 6a68027557..7d9bf57333 100644 --- a/collects/scribblings/scribble/basic.scrbl +++ b/collects/scribblings/scribble/basic.scrbl @@ -151,8 +151,12 @@ using @scheme[path->main-collects-relative].} @section{Text Styles} -@def-elem-proc[elem]{ Wraps the @tech{decode}d @scheme[pre-content] as -an element with style @scheme[#f].} +@defproc[(elem [pre-content any/c] ... + [#:style style any/c #f]) + element?]{ + +Wraps the @tech{decode}d @scheme[pre-content] as an element with style +@scheme[style].} @def-elem-proc[aux-elem]{Like @scheme[elem], but creates an @scheme[aux-element].} diff --git a/collects/scribblings/scribble/config.scrbl b/collects/scribblings/scribble/config.scrbl new file mode 100644 index 0000000000..0d03105771 --- /dev/null +++ b/collects/scribblings/scribble/config.scrbl @@ -0,0 +1,135 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + "utils.ss" + (for-label scheme/base)) + +@(define (nested . str) + (make-blockquote #f (flow-paragraphs (decode-flow str)))) +@(define (fake-title . str) (apply bold str)) + +@title[#:tag "config"]{Extending and Configuring Scribble Output} + +Sometimes, Scribble's primitives and built-in styles are insufficient +to produce the output that you need. The cases in which you need to +extend or configure Scribble fall into two groups: + +@itemize[ + + @item{You may need to drop into the back-end ``language'' of CSS or + Tex to create a specific output effect. For this kind of + extension, you will mostly likely attach a @scheme[`(css + ,_file)] or @scheme[`(tex ,_file)] style to a @scheme[section] + and then use a string defined in the @scheme[_file] as an + @scheme[element] or @tech{block} style. This kind of extension + is described in @secref["extra-style"].} + + @item{You may need to produce a document whose page layout is + different from the PLT Scheme documentation style. For that + kind of configuration, you will most likely run the + @exec{scribble} command-line tool and supply flags like + @DFlag{prefix} or @DPFlag{style}. This kind of configuration + is described in @secref["config-style"].} + +] + +@; ------------------------------------------------------------ + +@section[#:tag "extra-style" + #:style `((css "inbox.css") (tex "inbox.tex"))]{Adding a Style} + +When a string is uses as a style in an @scheme[element], +@scheme[styled-paragraph], or @scheme[blockquote], it corresponds to a +CSS class for HTML output or a Tex macro (or Latex environment, in the +case of @scheme[blockquote]) for Latex output. + +Scribble includes a number of predefined styles that are used by the +exports of @scheme[scribble/manual], but they are not generally +intended for direct use. For now, use them or redefine them at your +own risk. + +To add a mapping from your own style name to a CSS configuration, add +a @scheme[`(css ,_file)] style (in a list of styles) to an enclosing +@scheme[part]. To map a style name to a Tex macro (or Latex +environment), add a @scheme[`(tex ,_file)] style to an enclosing part. + +To avoid collisions with future additions to Scribble, start your +style name with an uppercase letter that is not @litchar{S}. An +uppercase letter helps to avoid collisions with macros defined by +Latex packages, and future styles needed by @scheme[scribble/manual] +will start with @litchar{s}. + +For example, a Scribble document + +@verbatim[#:indent 2]|{ + #lang scribble/doc + @(require manual) + + @title[#:style `((css "inbox.css") (tex "inbox.tex"))]{Quantum Pet} + + Do not open: @elem[#:style "InBox"]{Cat} +}| + +combined with an @filepath{inbox.css} that contains + +@verbatim[#:indent 2]|{ + .inbox { + padding: 0.2em; + border: 1px solid #000000; + } +}| + +and an @filepath{inbox.tex} that contains + +@verbatim[#:indent 2]|{ + \newcommand{\InBox}[1]{\fbox{#1}} +}| + +generates + +@nested{ + @fake-title{Quantum Pet} + + Do not open: @elem[#:style "InBox"]{Cat} +} + +@; ------------------------------------------------------------ + +@section[#:tag "config-style"]{Configuring Output} + +Scribble's output is configured in two layers: + +@itemize[ + + @item{A prefix determines the @tt{DOCTYPE} line for HTML output or + the @tt{documentclass} configuration (and perhaps some addition + package uses or other configuration) for Latex output. The + default prefix is @filepath{scribble-prefix.html} or + @filepath{scribble-prefix.tex} in the @filepath{scribble} + collection.} + + @item{Style definitions for all of the ``built-in'' styles used by + @scheme[scribble/manual] (as described in + @secref["extra-style"]). The default style definitions are + @filepath{scribble.css} or @filepath{scribble.tex} in the + @filepath{scribble} collection.} + +] + +When using the @exec{scribble} command-line utility: + +@itemize[ + + @item{Replace the prefix using the @as-index{@DFlag{prefix}} flag.} + + @item{Replace the style definitions using the + @as-index{@DFlag{style}} flag.} + + @item{Add style definitions (that can override earlier ones) + using the @as-index{@DPFlag{style}} flag.} + +] + +For now, reading the default files is the best way to understand how +they interact. diff --git a/collects/scribblings/scribble/how-to.scrbl b/collects/scribblings/scribble/how-to.scrbl index 63b6ff34ca..39c7ad4bd5 100644 --- a/collects/scribblings/scribble/how-to.scrbl +++ b/collects/scribblings/scribble/how-to.scrbl @@ -9,7 +9,11 @@ Although the @exec{scribble} command-line utility generates output from a Scribble document (run @exec{scribble -h} for more information), documentation of PLT Scheme libraries is normally built by @exec{setup-plt}. This chapter emphasizes the @exec{setup-plt} -approach, which more automatically supports links across documents. +approach, which more automatically supports links across +documents. + +@margin-note{See @secref["config"] for information on using the + @exec{scribble} command-line utility.} @;---------------------------------------- @section[#:tag "getting-started"]{Getting Started} diff --git a/collects/scribblings/scribble/inbox.css b/collects/scribblings/scribble/inbox.css new file mode 100644 index 0000000000..4cc3a9037f --- /dev/null +++ b/collects/scribblings/scribble/inbox.css @@ -0,0 +1,4 @@ +.inbox { + padding: 0.2em; + border: 1px solid #000000; +} diff --git a/collects/scribblings/scribble/inbox.tex b/collects/scribblings/scribble/inbox.tex new file mode 100644 index 0000000000..399a3ee234 --- /dev/null +++ b/collects/scribblings/scribble/inbox.tex @@ -0,0 +1,2 @@ + +\newcommand{\InBox}[1]{\fbox{#1}} diff --git a/collects/scribblings/scribble/scribble.scrbl b/collects/scribblings/scribble/scribble.scrbl index 37be0ce492..628e49110b 100644 --- a/collects/scribblings/scribble/scribble.scrbl +++ b/collects/scribblings/scribble/scribble.scrbl @@ -39,5 +39,6 @@ starting with the @filepath{scribble.scrbl} file. @include-section["bnf.scrbl"] @include-section["xref.scrbl"] @include-section["preprocessor.scrbl"] +@include-section["config.scrbl"] @index-section[] diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index f5d6556421..31bf12b3a8 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -257,9 +257,9 @@ to the section. The @scheme[title-content] field holds the part's title, if any. -The @scheme[style] field is normally either a symbol or a list of -symbols. The currently recognized style symbols (alone or in a list) -are as follows: +The @scheme[style] field is normally either a symbol or a list. The +currently recognized style symbols (alone or in a list) or other +values (must be in a list) are as follows: @itemize{ @@ -288,6 +288,12 @@ are as follows: multi-page documents) takes on the location and color of the main table of contents, instead.} + @item{@scheme[`(css ,_path)] --- generated HTML refers to (a copy + of) @scheme[_path] as CSS.} + + @item{@scheme[`(tex ,_path)] --- generated Latex includes + (a copy of) @scheme[_path] in the document header.} + } The @scheme[to-collect] field contains @techlink{content} that is @@ -350,7 +356,7 @@ The @scheme[style] can be @itemize[ @item{A string that corresponds to a CSS class for HTML output or a - macro for Latex output.} + macro for Latex output (see @secref["extra-style"]).} @item{An instance of @scheme[with-attributes], which combines a base style with a set of additional HTML attributes.} @@ -386,7 +392,7 @@ The @scheme[style] can be any of the following: @itemize[ @item{A string that corresponds to a CSS class for - HTML output.} + HTML output (see @secref["extra-style"]).} @item{@scheme['boxed] to render as a definition.} @@ -431,7 +437,8 @@ A @techlink{itemization} has a list of flows. A @techlink{blockquote} has a style and a list of @tech{blocks}. The @scheme[style] field is normally a string that corresponds to a CSS -class for HTML output. +class for HTML output or Latex environment for Latex output (see +@secref["extra-style"]). } @@ -452,7 +459,7 @@ The @scheme[style] field is normally either @itemize{ @item{a string, which corresponds to a CSS class for HTML output and - a macro name for Latex output;} + a macro name for Latex output (see @secref["extra-style"]);} @item{one of the symbols that all renderers recognize: @scheme['tt], @scheme['italic], @scheme['bold], @scheme['sf], From 42fad650c73fb9efb486db2a0eec58d46a1d5a13 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Feb 2009 21:40:45 +0000 Subject: [PATCH 082/142] delay 'scheme' expansion to expression position svn: r13794 --- collects/scribble/scheme.ss | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 9767ff7ee0..281603a8bc 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -653,10 +653,13 @@ [else `(quote ,v)]))) (define (cvt s) (datum->syntax #'here (stx->loc-s-expr s) #f)) - (syntax-case stx () - [(_ expr) #`(typeset-code #,(cvt #'expr))] - [(_ expr (... ...)) - #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))] + (if (eq? (syntax-local-context) 'expression) + (syntax-case stx () + [(_ expr) #`(typeset-code #,(cvt #'expr))] + [(_ expr (... ...)) + #`(typeset-code #,(cvt #'(code:line expr (... ...))))]) + (quasisyntax/loc stx + (#%expression #,stx)))))] [(_ code typeset-code uncode d->s) #'(define-code code typeset-code uncode d->s syntax-property)] [(_ code typeset-code uncode) From 2336b9c279a3d8651e825834e5722ec69478946d Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sun, 22 Feb 2009 23:38:54 +0000 Subject: [PATCH 083/142] removed 's world svn: r13795 --- collects/2htdp/private/world.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss index b94a99ef97..94ceb20d58 100644 --- a/collects/2htdp/private/world.ss +++ b/collects/2htdp/private/world.ss @@ -161,7 +161,7 @@ (define/augment (on-close) (callback-stop! 'frame-stop) (custodian-shutdown-all play-back:cust))) - (label (if name (format "~a's World" name) "World")) + (label (if name (format "~a" name) "World")) (stretchable-width #f) (stretchable-height #f) (style '(no-resize-border metal)))) From d3a8cd369ab6c6de17d76f558750f64ddc29f4cf Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 23 Feb 2009 03:19:29 +0000 Subject: [PATCH 084/142] typo in prefix-out example svn: r13798 --- collects/scribblings/reference/syntax.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index fea3da084c..3dd7d4786b 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -782,7 +782,7 @@ follows. @defexamples[#:eval (syntax-eval) (module a scheme - (provide (prefix-out f foo)) + (provide (prefix-out f: foo)) (define foo 2)) (require 'a) f:foo From 3eaaa282d8c8f708afae154a1c7c18bdee5cbbf4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Feb 2009 08:50:17 +0000 Subject: [PATCH 085/142] Welcome to a new PLT day. svn: r13799 --- 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 13dcd4e295..188a9e249d 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "22feb2009") +#lang scheme/base (provide stamp) (define stamp "23feb2009") From 6c0bcba37490abf642e56d44c1ba71d9b7a1b462 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Feb 2009 12:39:09 +0000 Subject: [PATCH 086/142] svn: r13800 --- .../games/chat-noir/chat-noir-literate.ss | 70 +++++++++++++------ 1 file changed, 49 insertions(+), 21 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 066597b77e..4a79317268 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,5 +1,11 @@ #lang scribble/lp +@;{ + +TODO: update-world-posn does not need to check the world-state anymore. + +} + @(require (for-label scheme/math) ;; for 'pi' below scheme/math games/scribblings/common) @@ -293,8 +299,19 @@ cats initial position as the center spot on the board. (block-cell (cell-p to-block) all-cells) board-size))])) + (define/contract (block-cell/world to-block w) + (-> posn? world? world?) + (make-world (block-cell to-block (world-board w)) + (world-cat w) + (world-state w) + (world-size w) + (world-mouse-posn w) + (world-h-down? w))) + + ;; block-cell : posn board -> board - (define (block-cell to-block board) + (define/contract (block-cell to-block board) + (-> posn? (listof cell?) (listof cell?)) (map (lambda (c) (if (equal? to-block (cell-p c)) (make-cell to-block true) c)) @@ -1096,6 +1113,7 @@ the screen resolution. @chunk[ + @@ -1113,27 +1131,37 @@ the screen resolution. ] +The @scheme[clack] function handles mouse input. It has three tasks and each corresponds +to a specific helper function: +@itemize{ +@item{block the clicked cell,} +@item{move the cat, and} +@item{update the black dot as the mouse moves around}} +Each of those tasks corresponds to a helper function + @chunk[ - (define (clack world x y evt) - (let ([new-mouse-posn - (and (not (eq? evt 'leave)) - (make-posn x y))]) - (update-world-posn - (cond - [(and (equal? evt 'button-up) - (equal? 'playing (world-state world)) - (circle-at-point (world-board world) x y)) - => - (λ (circle) - (move-cat - (make-world (block-cell circle (world-board world)) - (world-cat world) - (world-state world) - (world-size world) - (world-mouse-posn world) - (world-h-down? world))))] - [else world]) - new-mouse-posn)))] + (define/contract (clack world x y evt) + (-> world? integer? integer? any/c + world?) + (update-world-posn + (cond + [(player-moved? world x y evt) + => + (λ (circle) + (move-cat + (block-cell/world circle world)))] + [else world]) + (and (eq? (world-state world) 'playing) + (not (eq? evt 'leave)) + (make-posn x y))))] + +@chunk[ + (define/contract (player-moved? world x y evt) + (-> world? integer? integer? any/c + (or/c posn? #f)) + (and (equal? evt 'button-up) + (equal? 'playing (world-state world)) + (circle-at-point (world-board world) x y)))] @chunk[ (test (clack (make-world '() (make-posn 0 0) 'playing 3 false false) From ce79598a4a896d2f7b3c0ade5ed344b5b9691546 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Feb 2009 12:48:30 +0000 Subject: [PATCH 087/142] add body id tag support to Scribble svn: r13801 --- collects/scribble/html-render.ss | 16 +++++++++++++++- collects/scribblings/scribble/struct.scrbl | 8 ++++++++ collects/setup/scribble.ss | 11 +++++++++-- 3 files changed, 32 insertions(+), 3 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 542f095ec7..3349b37adf 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -572,6 +572,19 @@ (versioned-part-version d) (current-version))) + (define/public (extract-part-body-id d ri) + (or + (and (list? (part-style d)) + (ormap (lambda (s) + (and (list? s) + (= 2 (length s)) + (eq? (car s) 'body-id) + (string? (cadr s)) + (cadr s))) + (part-style d))) + (let ([p (part-parent d ri)]) + (and p (extract-part-body-id p ri))))) + (define/public (render-one-part d ri fn number) (parameterize ([current-output-file fn]) (let* ([prefix-file (or prefix-file scribble-prefix-html)] @@ -604,7 +617,8 @@ 'css (lambda (p) (part-whole-page? p ri))))) ,(scribble-js-contents script-file script-path)) - (body () + (body ((id ,(or (extract-part-body-id d ri) + "scribble-plt-scheme-org"))) ,@(render-toc-view d ri) (div ([class "maincolumn"]) (div ([class "main"]) diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index 31bf12b3a8..abdbfbd61d 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -294,6 +294,14 @@ values (must be in a list) are as follows: @item{@scheme[`(tex ,_path)] --- generated Latex includes (a copy of) @scheme[_path] in the document header.} + @item{@scheme[`(body-id ,_string)] --- generated HTML uses + @scheme[_string] as the @tt{id} attribute of the @tt{body} + tag; this style can be set separately for parts that start + different HTML pages, otherwise it is effectively inherited by + sub-parts; the default is @scheme["scribble-plt-scheme.org"], + but @exec{setup-plt} installs @scheme["doc-plt-scheme.org"] + as the @tt{id} for any document that it builds.} + } The @scheme[to-collect] field contains @techlink{content} that is diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index deb88f66f2..20caa3162f 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -310,12 +310,19 @@ (let ([tag-prefix p] [tags (if (member '(part "top") (part-tags v)) (part-tags v) - (cons '(part "top") (part-tags v)))]) + (cons '(part "top") (part-tags v)))] + [style (if (list? (part-style v)) + (part-style v) + (list (part-style v)))]) (make-versioned-part tag-prefix tags (part-title-content v) - (part-style v) + (if (ormap (lambda (s) + (and (pair? s) (eq? (car s) 'body-id))) + style) + style + (cons '(body-id "doc-plt-scheme-org") style)) (part-to-collect v) (part-flow v) (part-parts v) From 93d6a5fc7c2ef9d9391875d9e5f00f86314cb185 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 23 Feb 2009 14:36:28 +0000 Subject: [PATCH 088/142] * Just use new marks instead of name mangling for the ctc-ids * Set the 'inferred-name property appropriately. svn: r13802 --- collects/scheme/private/contract.ss | 65 +++++++++++++++-------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 7c631d9be0..db02530008 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -386,21 +386,20 @@ improve method arity mismatch contract violation error messages? (syntax id))] [(f arg ...) (quasisyntax/loc stx - ((let ([f (-contract contract-stx - #,id - pos-blame-id - neg-blame-id - #,(id->contract-src-info id))]) - f) arg ...))] + ((-contract contract-stx + #,id + pos-blame-id + neg-blame-id + #,(id->contract-src-info id)) + arg ...))] [ident (identifier? (syntax ident)) (quasisyntax/loc stx - (let ([ident (-contract contract-stx - #,id - pos-blame-id - neg-blame-id - #,(id->contract-src-info id))]) - ident))]))))) + (-contract contract-stx + #,id + pos-blame-id + neg-blame-id + #,(id->contract-src-info id)))]))))) (define-syntax (with-contract-helper stx) @@ -500,21 +499,20 @@ improve method arity mismatch contract violation error messages? (syntax id))] [(f arg ...) (quasisyntax/loc stx - ((let ([f (-contract #,ctc - #,fv - #,pos-blame - #,neg-blame - #,(id->contract-src-info fv))]) - f) arg ...))] + ((-contract #,ctc + #,fv + #,pos-blame + #,neg-blame + #,(id->contract-src-info fv)) + arg ...))] [ident (identifier? (syntax ident)) (quasisyntax/loc stx - (let ([ident (-contract #,ctc - #,fv - #,pos-blame - #,neg-blame - #,(id->contract-src-info fv))]) - ident))])))) + (-contract #,ctc + #,fv + #,pos-blame + #,neg-blame + #,(id->contract-src-info fv)))])))) (define-syntax (with-contract stx) (when (eq? (syntax-local-context) 'expression) @@ -544,6 +542,7 @@ improve method arity mismatch contract violation error messages? (and (identifier? #'blame) (identifier? #'type)) (let*-values ([(marker) (make-syntax-introducer)] + [(cid-marker) (make-syntax-introducer)] [(no-need free-vars free-ctcs) (check-and-split-with-contracts #f (syntax->list #'(fv ...)))] [(unprotected protected protections) @@ -558,15 +557,17 @@ improve method arity mismatch contract violation error messages? [blame-id (car (generate-temporaries (list #t)))] [(free-var ...) free-vars] [(free-var-id ...) (map marker free-vars)] - [(free-ctc-id ...) (map (λ (i) - (marker (a:mangle-id stx "with-contract-contract-id" i))) - free-vars)] - [(free-ctc ...) free-ctcs] + [(free-ctc-id ...) (map cid-marker free-vars)] + [(free-ctc ...) (map (λ (c v) + (syntax-property c 'inferred-name v)) + free-ctcs + free-vars)] [(free-src-info ...) (map id->contract-src-info free-vars)] - [(ctc-id ...) (map (λ (i) - (marker (a:mangle-id stx "with-contract-contract-id" i))) - protected)] - [(ctc ...) (map marker protections)] + [(ctc-id ...) (map cid-marker protected)] + [(ctc ...) (map (λ (c v) + (marker (syntax-property c 'inferred-name v))) + protections + protected)] [(p ...) protected] [(marked-p ...) (map marker protected)] [(src-info ...) (map (compose id->contract-src-info marker) protected)] From 3c0e17d9632fffa521f633afedd39efefe3ec5c7 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 23 Feb 2009 18:49:29 +0000 Subject: [PATCH 089/142] Add to the error message for -> in the case of optional arguments. svn: r13803 --- collects/scheme/private/contract-arrow.ss | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index ed9a29eda4..757353d83c 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -1427,11 +1427,14 @@ v4 todo: src-info blame orig-str - "expected a ~a that accepts ~a~a argument~a~a, given: ~e" + "expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e" (if mtd? "method" "procedure") (if (zero? dom-length) "no" dom-length) + (if (null? optionals) "" " mandatory") (if (null? mandatory-kwds) "" " ordinary") (if (= 1 dom-length) "" "s") + (if (zero? optionals) "" + (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s"))) (keyword-error-text mandatory-kwds optional-keywords) val))) From a303b781cc03ceb7ba25548a3599f990dbc18b1f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Feb 2009 21:40:43 +0000 Subject: [PATCH 090/142] svn: r13804 --- collects/drscheme/syncheck.ss | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 0e8256683e..a8e7d00dfd 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1846,7 +1846,7 @@ If the namespace does not, they are colored the unbound color. low-binders unused-requires requires - identifier-binding + 0 user-namespace user-directory #t)) @@ -1862,7 +1862,7 @@ If the namespace does not, they are colored the unbound color. high-binders unused-require-for-syntaxes require-for-syntaxes - identifier-transformer-binding + 1 user-namespace user-directory #t)) @@ -1877,7 +1877,7 @@ If the namespace does not, they are colored the unbound color. low-binders unused-requires requires - identifier-binding + 0 user-namespace user-directory #f) @@ -1886,7 +1886,7 @@ If the namespace does not, they are colored the unbound color. high-binders unused-require-for-syntaxes require-for-syntaxes - identifier-transformer-binding + 1 user-namespace user-directory #f) @@ -1895,7 +1895,7 @@ If the namespace does not, they are colored the unbound color. template-binders ;; dummy; always empty unused-require-for-templates require-for-templates - identifier-template-binding + -1 user-namespace user-directory #f) @@ -1904,7 +1904,7 @@ If the namespace does not, they are colored the unbound color. label-binders ;; dummy; always empty unused-require-for-labels require-for-labels - identifier-label-binding + #f user-namespace user-directory #f)) @@ -1952,7 +1952,7 @@ If the namespace does not, they are colored the unbound color. ;; id-set ;; (union #f hash-table) ;; (union #f hash-table) - ;; (union identifier-binding identifier-transformer-binding) + ;; integer or 'lexical or #f ;; (listof id-set) ;; namespace ;; directory @@ -1960,18 +1960,18 @@ If the namespace does not, they are colored the unbound color. ;; -> void ;; adds arrows and rename menus for binders/bindings (define (connect-identifier var rename-ht all-binders - unused requires get-binding user-namespace user-directory actual?) + unused requires phase-level user-namespace user-directory actual?) (connect-identifier/arrow var all-binders - unused requires get-binding user-namespace user-directory actual?) + unused requires phase-level user-namespace user-directory actual?) (when (and actual? (get-ids all-binders var)) (record-renamable-var rename-ht var))) - ;; id-level : identifier-binding-function identifier -> symbol - (define (id-level get-binding id) + ;; id-level : integer-or-#f-or-'lexical identifier -> symbol + (define (id-level phase-level id) (define (self-module? mpi) (let-values ([(a b) (module-path-index-split mpi)]) (and (not a) (not b)))) - (let ([binding (get-binding id)]) + (let ([binding (identifier-binding id phase-level)]) (cond [(list? binding) (if (self-module? (car binding)) 'top-level @@ -1987,16 +1987,16 @@ If the namespace does not, they are colored the unbound color. ;; boolean ;; -> void ;; adds the arrows that correspond to binders/bindings - (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) + (define (connect-identifier/arrow var all-binders unused requires phase-level user-namespace user-directory actual?) (let ([binders (get-ids all-binders var)]) (when binders (for-each (λ (x) (when (syntax-original? x) - (connect-syntaxes x var actual? (id-level get-binding x)))) + (connect-syntaxes x var actual? (id-level phase-level x)))) binders)) (when (and unused requires) - (let ([req-path/pr (get-module-req-path (get-binding var))]) + (let ([req-path/pr (get-module-req-path (identifier-binding var phase-level))]) (when req-path/pr (let* ([req-path (car req-path/pr)] [id (cdr req-path/pr)] @@ -2018,7 +2018,7 @@ If the namespace does not, they are colored the unbound color. (syntax-e var) req-path)) (connect-syntaxes req-stx var actual? - (id-level get-binding var)))) + (id-level phase-level var)))) req-stxes)))))))) (define (id/require-match? var id req-stx) @@ -2064,7 +2064,7 @@ If the namespace does not, they are colored the unbound color. (if top-bound? (color var lexically-bound-variable-style-name) (color var error-style-name)) - (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t))) + (connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t))) ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void (define (color-variable var get-binding) From 78dbc225981e467c8399b5aca535b9e69ccb1a72 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 23 Feb 2009 21:46:22 +0000 Subject: [PATCH 091/142] Try to set up the inferred-name property appropriately. svn: r13805 --- collects/mzlib/private/unit-contract.ss | 16 ++++---- collects/mzlib/private/unit-utils.ss | 14 +++---- collects/mzlib/unit.ss | 49 +++++++++++++------------ 3 files changed, 41 insertions(+), 38 deletions(-) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index a3813b91e2..a7e6a8fdb1 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -60,13 +60,15 @@ packed with the neg blame. ;; If contract coersion ends up being a large overhead, we can ;; store the result in a local box, then just check the box to ;; see if we need to coerce. - #`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))]) - ((((proj-get ctc) ctc) - #,(if import? neg pos) - #,(if import? pos neg) - #,src-info - #,name) - #,stx)))]) + (with-syntax ([ctc-stx (syntax-property #`(letrec-syntax #,rename-bindings #,ctc) + 'inferred-name var)]) + #`(let ([ctc (coerce-contract 'unit/c ctc-stx)]) + ((((proj-get ctc) ctc) + #,(if import? neg pos) + #,(if import? pos neg) + #,src-info + #,name) + #,stx))))]) (if ctc #`(cons #,(if import? diff --git a/collects/mzlib/private/unit-utils.ss b/collects/mzlib/private/unit-utils.ss index e4d8ac53bb..baf6a35cb1 100644 --- a/collects/mzlib/private/unit-utils.ss +++ b/collects/mzlib/private/unit-utils.ss @@ -43,13 +43,13 @@ (for/list ([i (in-list (map car (car sig)))] [c (in-list (cadddr sig))]) (let ([add-ctc - (λ (v stx) - (if c - #`(let ([v/c ((car #,stx))]) - (contract (let ([#,v #,c]) #,v) - (car v/c) (cdr v/c) #,blame - #,(id->contract-src-info v))) - #`((car #,stx))))]) + (λ (v stx) + (if c + (with-syntax ([c-stx (syntax-property c 'inferred-name v)]) + #`(let ([v/c ((car #,stx))]) + (contract c-stx (car v/c) (cdr v/c) #,blame + #,(id->contract-src-info v)))) + #`((car #,stx))))]) #`[#,i (make-set!-transformer (λ (stx) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8bfd095388..0b25cdcba1 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -790,30 +790,31 @@ [rename-bindings (get-member-bindings def-table (bound-identifier-mapping-get sig-table var) #'(current-contract-region))]) - (if (or target-ctc ctc) - #`(cons - (λ () - (let ([old-v #,(if ctc - #`(let ([old-v/c ((car #,vref))]) - (contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var) - (car old-v/c) - (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var))) - #`((car #,vref)))]) - #,(if target-ctc - #'(cons old-v (current-contract-region)) - #'old-v))) - (λ (v) (let ([new-v #,(if ctc - #`(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var) - (car v) - (current-contract-region) - (cdr v) - #,(id->contract-src-info var)) - #'v)]) - #,(if target-ctc - #`((cdr #,vref) (cons new-v (current-contract-region))) - #`((cdr #,vref) new-v))))) - vref))) + (with-syntax ([ctc-stx (if ctc (syntax-property + #`(letrec-syntax #,rename-bindings #,ctc) + 'inferred-name var) + ctc)]) + (if (or target-ctc ctc) + #`(cons + (λ () + (let ([old-v #,(if ctc + #`(let ([old-v/c ((car #,vref))]) + (contract ctc-stx (car old-v/c) + (cdr old-v/c) (current-contract-region) + #,(id->contract-src-info var))) + #`((car #,vref)))]) + #,(if target-ctc + #'(cons old-v (current-contract-region)) + #'old-v))) + (λ (v) (let ([new-v #,(if ctc + #`(contract ctc-stx (car v) + (current-contract-region) (cdr v) + #,(id->contract-src-info var)) + #'v)]) + #,(if target-ctc + #`((cdr #,vref) (cons new-v (current-contract-region))) + #`((cdr #,vref) new-v))))) + vref)))) (car target-sig) (cadddr target-sig))) target-import-sigs)) From e727f4fd083b3728d9531486f26d2be42e2bd882 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 23 Feb 2009 22:05:09 +0000 Subject: [PATCH 092/142] Fixing some more inferred-name placements. svn: r13806 --- collects/mzlib/private/unit-contract.ss | 36 ++++++++++++++----------- collects/mzlib/unit.ss | 21 +++++++++------ 2 files changed, 34 insertions(+), 23 deletions(-) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index a7e6a8fdb1..2447abfafa 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -60,15 +60,13 @@ packed with the neg blame. ;; If contract coersion ends up being a large overhead, we can ;; store the result in a local box, then just check the box to ;; see if we need to coerce. - (with-syntax ([ctc-stx (syntax-property #`(letrec-syntax #,rename-bindings #,ctc) - 'inferred-name var)]) - #`(let ([ctc (coerce-contract 'unit/c ctc-stx)]) - ((((proj-get ctc) ctc) - #,(if import? neg pos) - #,(if import? pos neg) - #,src-info - #,name) - #,stx))))]) + #`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))]) + ((((proj-get ctc) ctc) + #,(if import? neg pos) + #,(if import? pos neg) + #,src-info + #,name) + #,stx)))]) (if ctc #`(cons #,(if import? @@ -79,9 +77,13 @@ packed with the neg blame. #`(let ([old-v/c ((car #,vref))]) (cons #,(wrap-with-proj ctc - #`(contract #,sig-ctc (car old-v/c) - (cdr old-v/c) #,pos - #,(id->contract-src-info var))) + (with-syntax ([sig-ctc-stx + (syntax-property sig-ctc + 'inferred-name + var)]) + #`(contract sig-ctc-stx (car old-v/c) + (cdr old-v/c) #,pos + #,(id->contract-src-info var)))) #,neg)) (wrap-with-proj ctc #`((car #,vref))))]) old-v))) @@ -91,9 +93,13 @@ packed with the neg blame. #,(if sig-ctc #`(cons #,(wrap-with-proj ctc - #`(contract #,sig-ctc (car v) - (cdr v) #,neg - #,(id->contract-src-info var))) + (with-syntax ([sig-ctc-stx + (syntax-property sig-ctc + 'inferred-name + var)]) + #`(contract sig-ctc-stx (car v) + (cdr v) #,neg + #,(id->contract-src-info var)))) #,pos) (wrap-with-proj ctc #'v))]) ((cdr #,vref) new-v))) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 0b25cdcba1..64eed9164e 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -459,11 +459,12 @@ (define-for-syntax (make-import-unboxing var loc ctc) (if ctc - (quasisyntax/loc (error-syntax) - (quote-syntax (let ([v/c ((car #,loc))]) - (contract #,ctc (car v/c) (cdr v/c) - (current-contract-region) - #,(id->contract-src-info var))))) + (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) + (quasisyntax/loc (error-syntax) + (quote-syntax (let ([v/c ((car #,loc))]) + (contract ctc-stx (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info var)))))) (quasisyntax/loc (error-syntax) (quote-syntax ((car #,loc)))))) @@ -1278,9 +1279,13 @@ (map (λ (tb i v c) #`(let ([v/c ((car #,tb))]) #,(if c - #`(contract (letrec-syntax #,rename-bindings #,c) (car v/c) (cdr v/c) - (current-contract-region) - #,(id->contract-src-info v)) + (with-syntax ([ctc-stx + (syntax-property + #`(letrec-syntax #,rename-bindings #,c) + 'inferred-name v)]) + #`(contract ctc-stx (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info v))) #'v/c))) tbs (iota (length (car os))) From 5a1f31668d00469284ba9712078fdd2e854df53c Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 23 Feb 2009 22:22:06 +0000 Subject: [PATCH 093/142] More name-setting fun. svn: r13807 --- collects/mzlib/private/unit-contract.ss | 8 +++++--- collects/mzlib/unit.ss | 1 + 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 2447abfafa..7289ad41fe 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -3,6 +3,7 @@ (require (for-syntax scheme/base stxclass syntax/boundmap + syntax/name "unit-compiletime.ss" "unit-contract-syntax.ss" "unit-syntax.ss") @@ -134,7 +135,7 @@ packed with the neg blame. (define-for-syntax contract-imports (contract-imports/exports #t)) (define-for-syntax contract-exports (contract-imports/exports #f)) -(define-for-syntax (unit/c/core stx) +(define-for-syntax (unit/c/core name stx) (syntax-parse stx [(:import-clause/c :export-clause/c) (begin @@ -225,7 +226,7 @@ packed with the neg blame. (vector-immutable export-key ...)) ...) src-info pos name) (make-unit - #f + '#,name (vector-immutable (cons 'import-name (vector-immutable import-key ...)) ...) (vector-immutable (cons 'export-name @@ -269,7 +270,8 @@ packed with the neg blame. (define-syntax/err-param (unit/c stx) (syntax-case stx () [(_ . sstx) - (unit/c/core #'sstx)])) + (let ([name (syntax-local-infer-name stx)]) + (unit/c/core name #'sstx))])) (define (contract-check-helper sub-sig super-sig import? val src-info blame ctc) (define t (make-hash)) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 64eed9164e..b93bc54627 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1482,6 +1482,7 @@ (with-syntax ([new-unit exp] [unit-contract (unit/c/core + #'name (syntax/loc stx ((import (import-tagged-sig-id [i.x i.c] ...) ...) (export (export-tagged-sig-id [e.x e.c] ...) ...))))] From ab47ac0f10b012f05c74e76d70e82286fea69643 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 24 Feb 2009 00:03:57 +0000 Subject: [PATCH 094/142] fixed a problem with arrow-based requires svn: r13808 --- collects/drscheme/syncheck.ss | 98 +++++++++++++++--------- collects/tests/drscheme/syncheck-test.ss | 21 ++++- 2 files changed, 82 insertions(+), 37 deletions(-) diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index a8e7d00dfd..370b2bb615 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1499,7 +1499,7 @@ If the namespace does not, they are colored the unbound color. (λ (vars) (when jump-to-id (for-each (λ (id) - (let ([binding (identifier-binding id)]) + (let ([binding (identifier-binding id 0)]) (when (pair? binding) (let ([nominal-source-id (list-ref binding 3)]) (when (eq? nominal-source-id jump-to-id) @@ -1598,7 +1598,7 @@ If the namespace does not, they are colored the unbound color. ;; tops are used here because a binding free use of a set!'d variable ;; is treated just the same as (#%top . x). (when (syntax-original? (syntax var)) - (if (identifier-binding (syntax var)) + (if (identifier-binding (syntax var) 0) (add-id varrefs (syntax var)) (add-id tops (syntax var)))) @@ -1813,11 +1813,23 @@ If the namespace does not, they are colored the unbound color. [unused-require-for-syntaxes (make-hash)] [unused-require-for-templates (make-hash)] [unused-require-for-labels (make-hash)] + [requires/phases (make-hash)] + [unused/phases (make-hash)] ;; there is no define-for-template form, thus no for-template binders [template-binders (make-id-set)] [label-binders (make-id-set)] [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) + (hash-set! requires/phases 0 requires) + (hash-set! requires/phases 1 require-for-syntaxes) + (hash-set! requires/phases -1 require-for-templates) + (hash-set! requires/phases #f require-for-labels) + + (hash-set! unused/phases 0 unused-requires) + (hash-set! unused/phases 1 unused-require-for-syntaxes) + (hash-set! unused/phases -1 unused-require-for-templates) + (hash-set! unused/phases #f unused-require-for-labels) + (hash-for-each requires (λ (k v) (hash-set! unused-requires k #t))) (hash-for-each require-for-syntaxes @@ -1830,8 +1842,8 @@ If the namespace does not, they are colored the unbound color. (for-each (λ (vars) (for-each (λ (var) (when (syntax-original? var) - (color-variable var identifier-binding) - (document-variable var identifier-binding) + (color-variable var 0) + (document-variable var 0) (record-renamable-var rename-ht var))) vars)) (append (get-idss high-binders) @@ -1839,13 +1851,13 @@ If the namespace does not, they are colored the unbound color. (for-each (λ (vars) (for-each (λ (var) - (color-variable var identifier-binding) - (document-variable var identifier-binding) + (color-variable var 0) + (document-variable var 0) (connect-identifier var rename-ht low-binders - unused-requires - requires + unused/phases + requires/phases 0 user-namespace user-directory @@ -1855,13 +1867,13 @@ If the namespace does not, they are colored the unbound color. (for-each (λ (vars) (for-each (λ (var) - (color-variable var identifier-transformer-binding) - (document-variable var identifier-transformer-binding) + (color-variable var 1) + (document-variable var 1) (connect-identifier var rename-ht high-binders - unused-require-for-syntaxes - require-for-syntaxes + unused/phases + requires/phases 1 user-namespace user-directory @@ -1875,8 +1887,8 @@ If the namespace does not, they are colored the unbound color. (connect-identifier var rename-ht low-binders - unused-requires - requires + unused/phases + requires/phases 0 user-namespace user-directory @@ -1884,8 +1896,8 @@ If the namespace does not, they are colored the unbound color. (connect-identifier var rename-ht high-binders - unused-require-for-syntaxes - require-for-syntaxes + unused/phases + requires/phases 1 user-namespace user-directory @@ -1893,8 +1905,8 @@ If the namespace does not, they are colored the unbound color. (connect-identifier var rename-ht template-binders ;; dummy; always empty - unused-require-for-templates - require-for-templates + unused/phases + requires/phases -1 user-namespace user-directory @@ -1902,8 +1914,8 @@ If the namespace does not, they are colored the unbound color. (connect-identifier var rename-ht label-binders ;; dummy; always empty - unused-require-for-labels - require-for-labels + unused/phases + requires/phases #f user-namespace user-directory @@ -1960,9 +1972,11 @@ If the namespace does not, they are colored the unbound color. ;; -> void ;; adds arrows and rename menus for binders/bindings (define (connect-identifier var rename-ht all-binders - unused requires phase-level user-namespace user-directory actual?) + unused/phases requires/phases + phase-level user-namespace user-directory actual?) (connect-identifier/arrow var all-binders - unused requires phase-level user-namespace user-directory actual?) + unused/phases requires/phases + phase-level user-namespace user-directory actual?) (when (and actual? (get-ids all-binders var)) (record-renamable-var rename-ht var))) @@ -1987,7 +2001,7 @@ If the namespace does not, they are colored the unbound color. ;; boolean ;; -> void ;; adds the arrows that correspond to binders/bindings - (define (connect-identifier/arrow var all-binders unused requires phase-level user-namespace user-directory actual?) + (define (connect-identifier/arrow var all-binders unused/phases requires/phases phase-level user-namespace user-directory actual?) (let ([binders (get-ids all-binders var)]) (when binders (for-each (λ (x) @@ -1995,11 +2009,15 @@ If the namespace does not, they are colored the unbound color. (connect-syntaxes x var actual? (id-level phase-level x)))) binders)) - (when (and unused requires) - (let ([req-path/pr (get-module-req-path (identifier-binding var phase-level))]) + (when (and unused/phases requires/phases) + (let ([req-path/pr (get-module-req-path (identifier-binding var phase-level) + phase-level)]) (when req-path/pr - (let* ([req-path (car req-path/pr)] - [id (cdr req-path/pr)] + (let* ([req-path (list-ref req-path/pr 0)] + [id (list-ref req-path/pr 1)] + [req-phase-level (list-ref req-path/pr 2)] + [unused (hash-ref unused/phases req-phase-level)] + [requires (hash-ref requires/phases req-phase-level)] [req-stxes (hash-ref requires req-path (λ () #f))]) (when req-stxes (hash-remove! unused req-path) @@ -2043,15 +2061,23 @@ If the namespace does not, they are colored the unbound color. ;; get-module-req-path : binding -> (union #f (cons require-sexp sym)) ;; argument is the result of identifier-binding or identifier-transformer-binding - (define (get-module-req-path binding) + (define (get-module-req-path binding phase-level) (and (pair? binding) + (or (not (number? phase-level)) + (= phase-level + (+ (list-ref binding 5) + (list-ref binding 6)))) (let ([mod-path (list-ref binding 2)]) (cond [(module-path-index? mod-path) (let-values ([(base offset) (module-path-index-split mod-path)]) - (cons base (list-ref binding 3)))] + (list base + (list-ref binding 3) + (list-ref binding 5)))] [(symbol? mod-path) - (cons mod-path (list-ref binding 3))])))) + (list mod-path + (list-ref binding 3) + (list-ref binding 5))])))) ;; color/connect-top : namespace directory id-set syntax -> void (define (color/connect-top rename-ht user-namespace user-directory binders var) @@ -2066,9 +2092,9 @@ If the namespace does not, they are colored the unbound color. (color var error-style-name)) (connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t))) - ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void - (define (color-variable var get-binding) - (let* ([b (get-binding var)] + ;; color-variable : syntax phase-level -> void + (define (color-variable var phase-level) + (let* ([b (identifier-binding var phase-level)] [lexical? (or (not b) (eq? b 'lexical) @@ -2528,12 +2554,12 @@ If the namespace does not, they are colored the unbound color. ; - ;; document-variable : stx identifier-binding -> void - (define (document-variable stx get-binding) + ;; document-variable : stx phase-level -> void + (define (document-variable stx phase-level) (when (syntax-original? stx) (let ([defs-text (currently-processing-definitions-text)]) (when defs-text - (let ([binding-info (get-binding stx)]) + (let ([binding-info (identifier-binding stx phase-level)]) (when (and (pair? binding-info) (syntax-position stx) (syntax-span stx)) diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss index 875ee2c736..4c13e3f2d2 100644 --- a/collects/tests/drscheme/syncheck-test.ss +++ b/collects/tests/drscheme/syncheck-test.ss @@ -34,6 +34,7 @@ trigger runtime errors in check syntax. ;; tests : (listof test) (define tests (list + (build-test "12345" '(("12345" constant))) (build-test "'abcdef" @@ -829,7 +830,25 @@ trigger runtime errors in check syntax. (" " default-color) ("foldl" imported-variable) (")" default-color)) - #f))) + #f) + + (build-test "#lang scheme/base\n(require scheme)\n(define-syntax m (lambda (x) #'1))" + '(("#lang " default-color) + ("scheme/base" error) + ("\n(" default-color) + ("require" imported) + (" scheme)\n(" default-color) + ("define-syntax" imported) + (" " default-color) + ("m" lexically-bound) + (" (" default-color) + ("lambda" imported) + (" (" default-color) + ("x" lexically-bound) + (") " default-color) + ("#'" imported) + ("1))" default-color)) + (list '((27 33) (19 26) (36 49) (53 59) (64 66)))))) (define (run-test) (check-language-level #rx"Pretty") From b6e60bdd6e2878ff490f99c71ccc97056c4bed29 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 24 Feb 2009 01:36:48 +0000 Subject: [PATCH 095/142] fixed a bug in the way recursive metafunctions bound the recursive calls for use in 'where' clauses svn: r13809 --- collects/redex/private/reduction-semantics.ss | 6 +++--- collects/redex/private/rewrite-side-conditions.ss | 4 ++++ collects/redex/private/tl-test.ss | 10 ++++++++++ 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index ebfed67542..277b4ecc1c 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -977,9 +977,9 @@ [((tl-var tl-exp) ...) bindings]) (syntax (λ (name bindings) - (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) - (term-let ([tl-var (term tl-exp)] ...) - (term-let-fn ((name name)) + (term-let-fn ((name name)) + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + (term-let ([tl-var (term tl-exp)] ...) (term rhs))))))))) (syntax->list (syntax (lhs ...))) (syntax->list (syntax (rhs ...))) diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss index aa666c2913..58da06c255 100644 --- a/collects/redex/private/rewrite-side-conditions.ss +++ b/collects/redex/private/rewrite-side-conditions.ss @@ -34,6 +34,10 @@ (raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx)) (let loop ([term orig-stx]) (syntax-case term (side-condition variable-except variable-prefix hole name in-hole in-named-hole hide-hole side-condition cross) + [(side-condition pre-pat (and)) + ;; rewriting metafunctions (and possibly other things) that have no where, etc clauses + ;; end up with side-conditions that are empty 'and' expressions, so we just toss them here. + (loop #'pre-pat)] [(side-condition pre-pat exp) (with-syntax ([pat (loop (syntax pre-pat))]) (let-values ([(names names/ellipses) (extract-names all-nts what bind-names? (syntax pat))]) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index cd4a61e802..049dda3d01 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -536,6 +536,16 @@ 'no-exn) 'no-exn)) + (let () + ;; test that 'where' clauses can contain recursive calls. + (define-metafunction empty-language + [(f (any)) + x + (where x (f any))] + [(f any) any]) + (test (term (f ((((x)))))) + (term x))) + ;; test that tracing works properly ;; note that caching comes into play here (which is why we don't see the recursive calls) (let () From 42e64a0f232fa19c6d23e2bb878207315cc4e1c7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 24 Feb 2009 01:47:48 +0000 Subject: [PATCH 096/142] fixed default auto text bug and added string constant for auto text svn: r13810 --- collects/drscheme/private/module-language.ss | 8 ++++++-- collects/string-constants/english-string-constants.ss | 3 ++- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 169f2e84bf..da8dc8ebc9 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -368,7 +368,7 @@ [callback void])) (define auto-text-panel (new group-box-panel% [parent new-parent] - [label "Auto-text"])) ;!! need string-constant + [label (string-constant module-language-auto-text)])) (define auto-text-text-box (new text-field% [parent auto-text-panel] [label #f] @@ -490,7 +490,10 @@ (format "~s" vec)))) (define (get-auto-text) - (string-append (send auto-text-text-box get-value) "\n")) + (let ([str (send auto-text-text-box get-value)]) + (cond + [(equal? str "") ""] + [else (string-append str "\n")]))) (define (install-auto-text str) (send auto-text-text-box set-value (regexp-replace #rx"\n$" str ""))) @@ -500,6 +503,7 @@ (install-collection-paths '(default)) (update-buttons) + (install-auto-text default-auto-text) (case-lambda [() diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 86f0485563..e173f76b85 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -1045,7 +1045,8 @@ please adhere to these guidelines: (no-language-chosen "No language chosen") (module-language-one-line-summary "Run creates a REPL in the context of the module, including the module's declared language") - + (module-language-auto-text "Automatic #lang line") ;; shows up in the details section of the module language + ;;; from the `not a language language' used initially in drscheme. (must-choose-language "DrScheme cannot process programs until you choose a programming language.") From ccd5e84f5ef756a2fb2da34028c61f12c71d9314 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 24 Feb 2009 02:44:57 +0000 Subject: [PATCH 097/142] a little more progress on the mouse event handling section svn: r13811 --- .../games/chat-noir/chat-noir-literate.ss | 1066 +++++++++-------- 1 file changed, 544 insertions(+), 522 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 4a79317268..5a951e0ff6 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,11 +1,5 @@ #lang scribble/lp -@;{ - -TODO: update-world-posn does not need to check the world-state anymore. - -} - @(require (for-label scheme/math) ;; for 'pi' below scheme/math games/scribblings/common) @@ -194,13 +188,13 @@ And here is how that board looks as a list of cells. (test (empty-board 3) (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)))] + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 1 2) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 2 1) #f) + (make-cell (make-posn 2 2) #f)))] The @scheme[empty-board] function consists of two (nested) calls to @scheme[build-list] @@ -225,7 +219,7 @@ flattens the nested lists and the board-size (lambda (j) (make-cell (make-posn i j) - false)))))))) + #f)))))))) (define/contract ((not-corner? board-size) c) (-> (and/c natural-number/c odd? (>=/c 3)) @@ -244,8 +238,8 @@ For example, this is the empty world of size @scheme[3]. It puts the cat at @scheme[(make-posn 1 1)], sets the state to @scheme['playing], records the size @scheme[3], and sets the current mouse position -to @scheme[false] and the state of the ``h'' key to -@scheme[false]. +to @scheme[#f] and the state of the ``h'' key to +@scheme[#f]. @chunk[ @@ -254,8 +248,8 @@ to @scheme[false] and the state of the ``h'' key to (make-posn 1 1) 'playing 3 - false - false))] + #f + #f))] The @scheme[empty-world] function @@ -272,8 +266,8 @@ cats initial position as the center spot on the board. (quotient board-size 2)) 'playing board-size - false - false))] + #f + #f))] @chunk[ @@ -297,43 +291,25 @@ cats initial position as the center spot on the board. (add-n-random-blocked-cells (sub1 n) (block-cell (cell-p to-block) all-cells) - board-size))])) - - (define/contract (block-cell/world to-block w) - (-> posn? world? world?) - (make-world (block-cell to-block (world-board w)) - (world-cat w) - (world-state w) - (world-size w) - (world-mouse-posn w) - (world-h-down? w))) - - - ;; block-cell : posn board -> board - (define/contract (block-cell to-block board) - (-> posn? (listof cell?) (listof cell?)) - (map (lambda (c) (if (equal? to-block (cell-p c)) - (make-cell to-block true) - c)) - board))] + board-size))]))] @chunk[ (test (block-cell (make-posn 1 1) - (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 2) false))) - (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 2) false))) + (list (make-cell (make-posn 0 0) #f) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 2 2) #f))) + (list (make-cell (make-posn 0 0) #f) + (make-cell (make-posn 1 1) #t) + (make-cell (make-posn 2 2) #f))) (test (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) - true)) + #t)) 10) - (list (make-cell (make-posn 0 0) true))) + (list (make-cell (make-posn 0 0) #t))) (test (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) - false)) + #f)) 10) - (list (make-cell (make-posn 0 0) true)))] + (list (make-cell (make-posn 0 0) #t)))] @section{Breadth-first Search} @@ -661,7 +637,7 @@ of looking at the board and calculating coordinate offsets. (make-posn x (+ y 1)) (make-posn (+ x 1) (+ y 1)))])))] -The @scheme[on-boundary?] function returns @scheme[true] when +The @scheme[on-boundary?] function returns @scheme[#t] when the posn would be on the boundary of a board of size @scheme[board-size]. Note that this function does not have to special case the missing @scheme[posn]s from the corners. @@ -675,7 +651,7 @@ have to special case the missing @scheme[posn]s from the corners. (= (posn-x p) (- board-size 1)) (= (posn-y p) (- board-size 1))))] -The @scheme[in-bounds?] function returns @scheme[true] +The @scheme[in-bounds?] function returns @scheme[#t] when the @scheme[posn] is actually on the board, meaning that the coordinates of the @scheme[posn] are within the board's size, and that the @scheme[posn] is not one @@ -722,12 +698,12 @@ in the white circles and one not: (make-posn 2 2) 'playing 7 - false - true))]) + #f + #t))]) (test (on-the-path? (make-posn 1 0)) - true) + #t) (test (on-the-path? (make-posn 4 4)) - false))] + #f))] The computation of the shortest path to the boundary proceeds by computing two distance maps; the distance map to the boundary and the distance map @@ -753,14 +729,14 @@ lost the game. (lookup-in-table edge-distance-map (world-cat w))) (cond [(equal? cat-distance '∞) - (lambda (p) false)] + (lambda (p) #f)] [else (lambda (p) (equal? (+/f (lookup-in-table cat-distance-map p) (lookup-in-table edge-distance-map p)) cat-distance))]))] [else - (lambda (p) false)]))] + (lambda (p) #f)]))] Finally, the helper function @scheme[+/f] is just like @scheme[+], except that it returns @scheme['∞] if either argument is @scheme['∞]. @@ -961,7 +937,7 @@ over all of the @scheme[cell]s in @scheme[cs]. It starts with an empty rectangle and, one by one, puts the cells on @scheme[image]. @chunk[ - ;; render-board : board number (posn -> boolean) posn-or-false -> image + ;; render-board : board number (posn -> boolean) posn-or-#f -> image (define/contract (render-board cs world-size on-cat-path? mouse) (-> (listof cell?) natural-number/c @@ -1114,6 +1090,8 @@ the screen resolution. + + @@ -1134,26 +1112,35 @@ the screen resolution. The @scheme[clack] function handles mouse input. It has three tasks and each corresponds to a specific helper function: @itemize{ -@item{block the clicked cell,} -@item{move the cat, and} -@item{update the black dot as the mouse moves around}} -Each of those tasks corresponds to a helper function +@item{block the clicked cell (@scheme[block-cell/world]),} +@item{move the cat (@scheme[move-cat]), and} +@item{update the black dot as the mouse moves around (@scheme[update-world-posn]).}} +The helper functions are combined in the body of @scheme[clack], +first checking to see if the mouse event corresponds to a +player's move (via the @scheme[player-moved?] function. @chunk[ (define/contract (clack world x y evt) (-> world? integer? integer? any/c world?) - (update-world-posn - (cond - [(player-moved? world x y evt) - => - (λ (circle) - (move-cat - (block-cell/world circle world)))] - [else world]) - (and (eq? (world-state world) 'playing) - (not (eq? evt 'leave)) - (make-posn x y))))] + (let ([moved-world + (cond + [(player-moved? world x y evt) + => + (λ (circle) + (move-cat + (block-cell/world circle world)))] + [else world])]) + (update-world-posn + moved-world + (and (eq? (world-state moved-world) 'playing) + (not (eq? evt 'leave)) + (make-posn x y)))))] + +The @scheme[player-moved?] predicate returns +a @scheme[posn] indicating where the player chose +to move when the mouse event corresponds to a player move, +and returns @scheme[#f]. @chunk[ (define/contract (player-moved? world x y evt) @@ -1163,314 +1150,205 @@ Each of those tasks corresponds to a helper function (equal? 'playing (world-state world)) (circle-at-point (world-board world) x y)))] -@chunk[ - (test (clack (make-world '() (make-posn 0 0) 'playing 3 false false) - 1 1 'button-down) - (make-world '() (make-posn 0 0) 'playing 3 #f false)) - (test (clack (make-world '() (make-posn 0 0) 'playing 3 false false) - 1 1 'drag) - (make-world '() (make-posn 0 0) 'playing 3 false false)) - (test (clack (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 3 - false - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'move) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 3 - (make-posn 0 0) - false)) - (test (clack (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 3 - false - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'enter) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) - 'playing - 3 - (make-posn 0 0) - false)) - (test (clack (make-world '() (make-posn 0 0) - 'playing 3 (make-posn 0 0) false) - 1 1 'leave) - (make-world '() (make-posn 0 0) 'playing 3 false false)) - - (test (clack (make-world '() (make-posn 0 0) - 'playing 3 (make-posn 0 0) false) - 10 - 10 - 'button-down) - (make-world '() (make-posn 0 0) 'playing 3 false false)) - - (test (clack (make-world (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 1 1) false)) - (make-posn 1 1) - 'playing - 3 - (make-posn 0 0) - false) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)) - 'button-up) - (make-world (list (make-cell (make-posn 0 0) true) - (make-cell (make-posn 1 1) false)) - (make-posn 1 1) - 'cat-lost - 3 - (make-posn 0 0) - false)) - - - (test (clack (make-world '() (make-posn 0 0) - 'cat-lost 3 (make-posn 0 0) false) - 10 - 10 - 'button-up) - (make-world '() (make-posn 0 0) - 'cat-lost 3 (make-posn 0 0) false)) - (test (clack - (make-world - (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'playing - 3 - false - false) - (cell-center-x (make-posn 1 0)) - (cell-center-y (make-posn 1 0)) - 'button-up) - (make-world - (list (make-cell (make-posn 1 0) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'cat-lost - 3 - false - false)) - - (test (clack - (make-world - (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 1 1) - 'playing - 3 - false - false) - (cell-center-x (make-posn 1 0)) - (cell-center-y (make-posn 1 0)) - 'button-up) - (make-world - (list (make-cell (make-posn 1 0) true) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) true)) - (make-posn 2 0) - 'cat-won - 3 - false - false))] +In the event that @scheme[player-moved?] returns a @scheme[posn], +the @scheme[clack] function blocks the clicked on cell using +@scheme[block-cell/world], which simply calls @scheme[block-cell]. + +@chunk[ + (define/contract (block-cell/world to-block w) + (-> posn? world? world?) + (make-world (block-cell to-block (world-board w)) + (world-cat w) + (world-state w) + (world-size w) + (world-mouse-posn w) + (world-h-down? w)))] + +The @scheme[block-cell] function accepts a @scheme[posn] +and a list of @scheme[cell] structs and updates the +relevant cell, setting its @tt{blocked?} field to @scheme[#t]. + +@chunk[ + (define/contract (block-cell to-block board) + (-> posn? (listof cell?) (listof cell?)) + (map (lambda (c) (if (equal? to-block (cell-p c)) + (make-cell to-block #t) + c)) + board))] + +The @scheme[move-cat] function uses calls @scheme[build-bfs-table] +to find the shortest distance from all of the cells to the boundary, +and then uses @scheme[find-best-positions] to compute the +list of neighbors of the cat that have the shortest distance +to the boundary. If that list is empty, then @scheme[next-cat-position] +is @scheme[#f], and otherwise, it is a random element from that list. + +@chunk[ + (define/contract (move-cat world) + (-> world? world?) + (let* ([cat-position (world-cat world)] + [table (build-bfs-table world 'boundary)] + [neighbors (adjacent cat-position)] + [next-cat-positions + (find-best-positions neighbors + (map (lambda (p) (lookup-in-table table p)) + neighbors))] + [next-cat-position + (cond + [(boolean? next-cat-positions) #f] + [else + (list-ref next-cat-positions + (random (length next-cat-positions)))])]) + + ))] + +Once @scheme[next-cat-position] has been computed, it is used to update +the @tt{cat} and @tt{state} fields of the world, recording the cat's new +position and whether or not the cat won. + +@chunk[ + (make-world (world-board world) + (cond + [(boolean? next-cat-position) + cat-position] + [else next-cat-position]) + (cond + [(boolean? next-cat-position) + 'cat-lost] + [(on-boundary? next-cat-position (world-size world)) + 'cat-won] + [else 'playing]) + (world-size world) + (world-mouse-posn world) + (world-h-down? world))] + +Finally, to complete the mouse event handling, the @scheme[update-world-posn] +function is called from @scheme[clack]. It updates @chunk[ - ;; update-world-posn/playing : world posn-or-false -> world - (define (update-world-posn w p) + (define/contract (update-world-posn w p) + (-> world? (or/c #f posn?) + world?) (cond - [(equal? (world-state w) 'playing) - (cond - [(posn? p) - (let ([mouse-spot - (circle-at-point (world-board w) - (posn-x p) - (posn-y p))]) - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - (cond - [(equal? mouse-spot (world-cat w)) - false] - [else - mouse-spot]) - (world-h-down? w)))] - [else - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - false - (world-h-down? w))])] - [else w]))] + [(posn? p) + (let ([mouse-spot + (circle-at-point (world-board w) + (posn-x p) + (posn-y p))]) + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + (cond + [(equal? mouse-spot (world-cat w)) + #f] + [else + mouse-spot]) + (world-h-down? w)))] + [else + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + #f + (world-h-down? w))]))] @chunk[ (test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'playing 3 false false) + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) 'playing 3 #f #f) (make-posn (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'playing 3 (make-posn 0 0) false)) + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) 'playing 3 (make-posn 0 0) #f)) (test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 0) 'playing 3 false false) + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 0) 'playing 3 #f #f) (make-posn (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 0) 'playing 3 false false)) + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 0) 'playing 3 #f #f)) (test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'playing 3 (make-posn 0 0) false) + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) 'playing 3 (make-posn 0 0) #f) (make-posn 0 0)) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'playing 3 false false)) - (test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'cat-won 3 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'cat-won 3 false false)) - (test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'cat-lost 3 false false) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) - (make-posn 0 1) 'cat-lost 3 false false))] - -@chunk[ - ;; move-cat : world -> world - (define (move-cat world) - (local [(define cat-position (world-cat world)) - (define table (build-bfs-table world 'boundary)) - (define neighbors (adjacent cat-position)) - (define next-cat-positions - (find-best-positions neighbors - (map (lambda (p) (lookup-in-table table p)) - neighbors))) - (define next-cat-position - (cond - [(boolean? next-cat-positions) false] - [else - (list-ref next-cat-positions - (random (length next-cat-positions)))]))] - (make-world (world-board world) - (cond - [(boolean? next-cat-position) - cat-position] - [else next-cat-position]) - (cond - [(boolean? next-cat-position) - 'cat-lost] - [(on-boundary? next-cat-position (world-size world)) - 'cat-won] - [else 'playing]) - (world-size world) - (world-mouse-posn world) - (world-h-down? world))))] + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) 'playing 3 #f #f))] @chunk[ (test (move-cat - (make-world (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 3 0) false) - (make-cell (make-posn 4 0) false) + (make-world (list (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 3 0) #f) + (make-cell (make-posn 4 0) #f) - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 3 1) false) - (make-cell (make-posn 4 1) false) + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 1) #t) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 3 1) #f) + (make-cell (make-posn 4 1) #f) - (make-cell (make-posn 0 2) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) false) - (make-cell (make-posn 3 2) true) - (make-cell (make-posn 4 2) false) + (make-cell (make-posn 0 2) #f) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 2) #f) + (make-cell (make-posn 3 2) #t) + (make-cell (make-posn 4 2) #f) - (make-cell (make-posn 0 3) false) - (make-cell (make-posn 1 3) true) - (make-cell (make-posn 2 3) false) - (make-cell (make-posn 3 3) false) - (make-cell (make-posn 4 3) false) + (make-cell (make-posn 0 3) #f) + (make-cell (make-posn 1 3) #t) + (make-cell (make-posn 2 3) #f) + (make-cell (make-posn 3 3) #f) + (make-cell (make-posn 4 3) #f) - (make-cell (make-posn 1 4) false) - (make-cell (make-posn 2 4) false) - (make-cell (make-posn 3 4) false) - (make-cell (make-posn 4 4) false)) + (make-cell (make-posn 1 4) #f) + (make-cell (make-posn 2 4) #f) + (make-cell (make-posn 3 4) #f) + (make-cell (make-posn 4 4) #f)) (make-posn 2 2) 'playing 5 (make-posn 0 0) - false)) - (make-world (list (make-cell (make-posn 1 0) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 3 0) false) - (make-cell (make-posn 4 0) false) + #f)) + (make-world (list (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 3 0) #f) + (make-cell (make-posn 4 0) #f) - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 3 1) false) - (make-cell (make-posn 4 1) false) + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 1) #t) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 3 1) #f) + (make-cell (make-posn 4 1) #f) - (make-cell (make-posn 0 2) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 2) false) - (make-cell (make-posn 3 2) true) - (make-cell (make-posn 4 2) false) + (make-cell (make-posn 0 2) #f) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 2) #f) + (make-cell (make-posn 3 2) #t) + (make-cell (make-posn 4 2) #f) - (make-cell (make-posn 0 3) false) - (make-cell (make-posn 1 3) true) - (make-cell (make-posn 2 3) false) - (make-cell (make-posn 3 3) false) - (make-cell (make-posn 4 3) false) + (make-cell (make-posn 0 3) #f) + (make-cell (make-posn 1 3) #t) + (make-cell (make-posn 2 3) #f) + (make-cell (make-posn 3 3) #f) + (make-cell (make-posn 4 3) #f) - (make-cell (make-posn 1 4) false) - (make-cell (make-posn 2 4) false) - (make-cell (make-posn 3 4) false) - (make-cell (make-posn 4 4) false)) + (make-cell (make-posn 1 4) #f) + (make-cell (make-posn 2 4) #f) + (make-cell (make-posn 3 4) #f) + (make-cell (make-posn 4 4) #f)) (make-posn 2 3) 'playing 5 (make-posn 0 0) - false))] + #f))] @chunk[ ;; find-best-positions : (nelistof posn) (nelistof number or '∞) - ;; -> (nelistof posn) or false + ;; -> (nelistof posn) or #f (define (find-best-positions posns scores) (local [(define best-score (foldl (lambda (x sofar) (if (<=/f x sofar) @@ -1479,7 +1357,7 @@ Each of those tasks corresponds to a helper function (first scores) (rest scores)))] (cond - [(symbol? best-score) false] + [(symbol? best-score) #f] [else (map second @@ -1490,7 +1368,7 @@ Each of those tasks corresponds to a helper function (test (find-best-positions (list (make-posn 0 0)) (list 1)) (list (make-posn 0 0))) (test (find-best-positions (list (make-posn 0 0)) (list '∞)) - false) + #f) (test (find-best-positions (list (make-posn 0 0) (make-posn 1 1)) (list 1 2)) @@ -1507,29 +1385,29 @@ Each of those tasks corresponds to a helper function (test (find-best-positions (list (make-posn 0 0) (make-posn 1 1)) (list '∞ '∞)) - false)] + #f)] @chunk[ ;; <=/f : (number or '∞) (number or '∞) -> boolean (define (<=/f a b) (cond - [(equal? b '∞) true] - [(equal? a '∞) false] + [(equal? b '∞) #t] + [(equal? a '∞) #f] [else (<= a b)]))] @chunk[ - (test (<=/f 1 2) true) - (test (<=/f 2 1) false) - (test (<=/f '∞ 1) false) - (test (<=/f 1 '∞) true) - (test (<=/f '∞ '∞) true)] + (test (<=/f 1 2) #t) + (test (<=/f 2 1) #f) + (test (<=/f '∞ 1) #f) + (test (<=/f 1 '∞) #t) + (test (<=/f '∞ '∞) #t)] @chunk[ - ;; circle-at-point : board number number -> posn-or-false + ;; circle-at-point : board number number -> posn-or-#f ;; returns the posn corresponding to cell where the x,y coordinates are (define (circle-at-point board x y) (cond - [(empty? board) false] + [(empty? board) #f] [else (cond [(point-in-this-circle? (cell-p (first board)) x y) @@ -1538,14 +1416,14 @@ Each of those tasks corresponds to a helper function (circle-at-point (rest board) x y)])]))] @chunk[ - (test (circle-at-point empty 0 0) false) - (test (circle-at-point (list (make-cell (make-posn 0 0) false)) + (test (circle-at-point empty 0 0) #f) + (test (circle-at-point (list (make-cell (make-posn 0 0) #f)) (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0))) (make-posn 0 0)) - (test (circle-at-point (list (make-cell (make-posn 0 0) false)) + (test (circle-at-point (list (make-cell (make-posn 0 0) #f)) 0 0) - false)] + #f)] @chunk[ ;; point-in-this-circle? : posn number number -> boolean @@ -1561,9 +1439,9 @@ Each of those tasks corresponds to a helper function (test (point-in-this-circle? (make-posn 0 0) (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0))) - true) + #t) (test (point-in-this-circle? (make-posn 0 0) 0 0) - false)] + #f)] @chunk[ ;; change : world key-event -> world @@ -1577,14 +1455,14 @@ Each of those tasks corresponds to a helper function @chunk[ (test (change (make-world '() (make-posn 1 1) - 'playing 3 (make-posn 0 0) false) + 'playing 3 (make-posn 0 0) #f) #\h) (make-world '() (make-posn 1 1) - 'playing 3 (make-posn 0 0) true)) + 'playing 3 (make-posn 0 0) #t)) (test (change (make-world '() (make-posn 1 1) - 'playing 3 (make-posn 0 0) true) + 'playing 3 (make-posn 0 0) #t) 'release) - (make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) false))] + (make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) #f))] ] @@ -1640,10 +1518,10 @@ for the other functions in this document (andmap (lambda (e2) (member e2 l1)) l2) #t)) -(test (same-sets? (list) (list)) true) -(test (same-sets? (list) (list 1)) false) -(test (same-sets? (list 1) (list)) false) -(test (same-sets? (list 1 2) (list 2 1)) true)] +(test (same-sets? (list) (list)) #t) +(test (same-sets? (list) (list 1)) #f) +(test (same-sets? (list 1) (list)) #f) +(test (same-sets? (list 1 2) (list 2 1)) #t)] @chunk[ (test (lookup-in-table empty (make-posn 1 2)) '∞) @@ -1657,7 +1535,7 @@ for the other functions in this document @chunk[ (test/set (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) - 'playing 3 (make-posn 0 0) false) + 'playing 3 (make-posn 0 0) #f) (make-posn 1 1)) (list (make-dist-cell 'boundary 2) @@ -1675,18 +1553,18 @@ for the other functions in this document (test/set (build-bfs-table (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) + (make-cell (make-posn 0 1) #t) + (make-cell (make-posn 1 0) #t) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 0) #t) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 2 2) #t)) (make-posn 1 1) 'playing 3 (make-posn 0 0) - false) + #f) 'boundary) (list (make-dist-cell 'boundary 0))) @@ -1697,7 +1575,7 @@ for the other functions in this document 'playing 5 (make-posn 0 0) - false) + #f) 'boundary) (list (make-dist-cell 'boundary 0) @@ -1738,7 +1616,7 @@ for the other functions in this document 'playing 5 (make-posn 0 0) - false) + #f) 'boundary) (list (make-dist-cell 'boundary 0) @@ -1776,7 +1654,7 @@ for the other functions in this document 'playing 5 (make-posn 0 0) - false) + #f) (make-posn 2 2)) (list (make-dist-cell 'boundary 3) @@ -1815,7 +1693,7 @@ for the other functions in this document 'playing 5 (make-posn 0 0) - false) + #f) (make-posn 2 2)) (make-posn 1 4)) 2)] @@ -1833,33 +1711,33 @@ for the other functions in this document (make-posn 2 1) (make-posn 2 2))) (test ((neighbors (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 1 1) #t) + (make-cell (make-posn 1 2) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 2 1) #f) + (make-cell (make-posn 2 2) #f)) (make-posn 1 1) 'playing 3 (make-posn 0 0) - false)) + #f)) (make-posn 1 1)) '()) (test ((neighbors (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) true) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 1 1) #t) + (make-cell (make-posn 1 2) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 2 1) #f) + (make-cell (make-posn 2 2) #f)) (make-posn 1 1) 'playing 3 (make-posn 0 0) - false)) + #f)) (make-posn 1 0)) (list 'boundary (make-posn 2 0) (make-posn 0 1)))] @@ -1881,25 +1759,25 @@ for the other functions in this document @chunk[ - (test (on-boundary? (make-posn 0 1) 13) true) - (test (on-boundary? (make-posn 1 0) 13) true) - (test (on-boundary? (make-posn 12 1) 13) true) - (test (on-boundary? (make-posn 1 12) 13) true) - (test (on-boundary? (make-posn 1 1) 13) false) - (test (on-boundary? (make-posn 10 10) 13) false)] + (test (on-boundary? (make-posn 0 1) 13) #t) + (test (on-boundary? (make-posn 1 0) 13) #t) + (test (on-boundary? (make-posn 12 1) 13) #t) + (test (on-boundary? (make-posn 1 12) 13) #t) + (test (on-boundary? (make-posn 1 1) 13) #f) + (test (on-boundary? (make-posn 10 10) 13) #f)] @chunk[ - (test (in-bounds? (make-posn 0 0) 11) false) - (test (in-bounds? (make-posn 0 1) 11) true) - (test (in-bounds? (make-posn 1 0) 11) true) - (test (in-bounds? (make-posn 10 10) 11) true) - (test (in-bounds? (make-posn 0 -1) 11) false) - (test (in-bounds? (make-posn -1 0) 11) false) - (test (in-bounds? (make-posn 0 11) 11) false) - (test (in-bounds? (make-posn 11 0) 11) false) - (test (in-bounds? (make-posn 10 0) 11) true) - (test (in-bounds? (make-posn 0 10) 11) false)] + (test (in-bounds? (make-posn 0 0) 11) #f) + (test (in-bounds? (make-posn 0 1) 11) #t) + (test (in-bounds? (make-posn 1 0) 11) #t) + (test (in-bounds? (make-posn 10 10) 11) #t) + (test (in-bounds? (make-posn 0 -1) 11) #f) + (test (in-bounds? (make-posn -1 0) 11) #f) + (test (in-bounds? (make-posn 0 11) 11) #f) + (test (in-bounds? (make-posn 11 0) 11) #f) + (test (in-bounds? (make-posn 10 0) 11) #t) + (test (in-bounds? (make-posn 0 10) 11) #f)] @chunk[ (test ((on-cats-path? (make-world (empty-board 5) @@ -1907,38 +1785,38 @@ for the other functions in this document 'playing 5 (make-posn 0 0) - true)) + #t)) (make-posn 1 0)) - true) + #t) (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) - false)) + #f)) (make-posn 1 0)) - false) + #f) (test ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) - 'playing 5 (make-posn 0 0) true)) + 'playing 5 (make-posn 0 0) #t)) (make-posn 2 1)) - false) + #f) (test ((on-cats-path? (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) + (make-cell (make-posn 0 1) #t) + (make-cell (make-posn 1 0) #t) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 0) #t) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 2 2) #t)) (make-posn 1 1) 'cat-lost 3 (make-posn 0 0) - true)) + #t)) (make-posn 0 1)) - false)] + #f)] @chunk[<+/f-tests> @@ -1951,51 +1829,51 @@ for the other functions in this document (test (render-world - (make-world (list (make-cell (make-posn 0 1) false)) + (make-world (list (make-cell (make-posn 0 1) #f)) (make-posn 0 1) 'playing 3 (make-posn 0 0) - false)) + #f)) (overlay - (render-board (list (make-cell (make-posn 0 1) false)) + (render-board (list (make-cell (make-posn 0 1) #f)) 3 - (lambda (x) true) - false) + (lambda (x) #t) + #f) (move-pinhole thinking-cat (- (cell-center-x (make-posn 0 1))) (- (cell-center-y (make-posn 0 1)))))) (test (render-world - (make-world (list (make-cell (make-posn 0 1) false)) + (make-world (list (make-cell (make-posn 0 1) #f)) (make-posn 0 1) 'cat-won 3 - false - false)) + #f + #f)) (overlay - (render-board (list (make-cell (make-posn 0 1) false)) + (render-board (list (make-cell (make-posn 0 1) #f)) 3 - (lambda (x) true) - false) + (lambda (x) #t) + #f) (move-pinhole happy-cat (- (cell-center-x (make-posn 0 1))) (- (cell-center-y (make-posn 0 1)))))) (test (render-world - (make-world (list (make-cell (make-posn 0 1) false)) + (make-world (list (make-cell (make-posn 0 1) #f)) (make-posn 0 1) 'cat-lost 3 - false - false)) + #f + #f)) (overlay - (render-board (list (make-cell (make-posn 0 1) false)) + (render-board (list (make-cell (make-posn 0 1) #f)) 3 - (lambda (x) true) - false) + (lambda (x) #t) + #f) (move-pinhole mad-cat (- (cell-center-x (make-posn 0 1))) (- (cell-center-y (make-posn 0 1)))))) @@ -2003,30 +1881,30 @@ for the other functions in this document (test (render-world (make-world (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) + (make-cell (make-posn 0 1) #t) + (make-cell (make-posn 1 0) #t) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 0) #t) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 2 2) #t)) (make-posn 1 1) 'cat-lost 3 - false - false)) + #f + #f)) (overlay (render-board (list - (make-cell (make-posn 0 1) true) - (make-cell (make-posn 1 0) true) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) true) - (make-cell (make-posn 2 0) true) - (make-cell (make-posn 2 1) true) - (make-cell (make-posn 2 2) true)) + (make-cell (make-posn 0 1) #t) + (make-cell (make-posn 1 0) #t) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 0) #t) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 2 2) #t)) 3 - (lambda (x) false) - false) + (lambda (x) #f) + #f) (move-pinhole mad-cat (- (cell-center-x (make-posn 1 1))) (- (cell-center-y (make-posn 1 1)))))) @@ -2034,31 +1912,31 @@ for the other functions in this document (test (render-world (make-world (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 1 2) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 2 1) #f) + (make-cell (make-posn 2 2) #f)) (make-posn 1 1) 'cat-lost 3 (make-posn (cell-center-x (make-posn 0 1)) (cell-center-y (make-posn 0 1))) - true)) + #t)) (overlay (render-board (list - (make-cell (make-posn 0 1) false) - (make-cell (make-posn 1 0) false) - (make-cell (make-posn 1 1) false) - (make-cell (make-posn 1 2) false) - (make-cell (make-posn 2 0) false) - (make-cell (make-posn 2 1) false) - (make-cell (make-posn 2 2) false)) + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 1 2) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 2 1) #f) + (make-cell (make-posn 2 2) #f)) 3 - (lambda (x) true) + (lambda (x) #t) (make-posn (cell-center-x (make-posn 0 1)) (cell-center-y (make-posn 0 1)))) (move-pinhole mad-cat @@ -2078,7 +1956,7 @@ for the other functions in this document 'playing 3 (make-posn 0 0) - false))) + #f))) 0) (test (pinhole-x @@ -2089,69 +1967,69 @@ for the other functions in this document 'playing 3 (make-posn 0 0) - false))) + #f))) 0)] @chunk[ - (test (render-board (list (make-cell (make-posn 0 0) false)) + (test (render-board (list (make-cell (make-posn 0 0) #f)) 3 - (lambda (x) false) - false) + (lambda (x) #f) + #f) (overlay (nw:rectangle (world-width 3) (world-height 3) 'solid 'white) - (render-cell (make-cell (make-posn 0 0) false) - false - false))) + (render-cell (make-cell (make-posn 0 0) #f) + #f + #f))) - (test (render-board (list (make-cell (make-posn 0 0) false)) + (test (render-board (list (make-cell (make-posn 0 0) #f)) 3 - (lambda (x) true) - false) + (lambda (x) #t) + #f) (overlay (nw:rectangle (world-width 3) (world-height 3) 'solid 'white) - (render-cell (make-cell (make-posn 0 0) false) - true - false))) + (render-cell (make-cell (make-posn 0 0) #f) + #t + #f))) - (test (render-board (list (make-cell (make-posn 0 0) false)) + (test (render-board (list (make-cell (make-posn 0 0) #f)) 3 - (lambda (x) false) - false) + (lambda (x) #f) + #f) (overlay (nw:rectangle (world-width 3) (world-height 3) 'solid 'white) - (render-cell (make-cell (make-posn 0 0) false) - false - false))) + (render-cell (make-cell (make-posn 0 0) #f) + #f + #f))) - (test (render-board (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) + (test (render-board (list (make-cell (make-posn 0 0) #f) + (make-cell (make-posn 0 1) #f)) 3 (lambda (x) (equal? x (make-posn 0 1))) - false) + #f) (overlay (nw:rectangle (world-width 3) (world-height 3) 'solid 'white) - (render-cell (make-cell (make-posn 0 0) false) - false - false) - (render-cell (make-cell (make-posn 0 1) false) - true - false))) + (render-cell (make-cell (make-posn 0 0) #f) + #f + #f) + (render-cell (make-cell (make-posn 0 1) #f) + #t + #f))) - (test (render-board (list (make-cell (make-posn 0 0) false) - (make-cell (make-posn 0 1) false)) + (test (render-board (list (make-cell (make-posn 0 0) #f) + (make-cell (make-posn 0 1) #f)) 3 (lambda (x) (equal? x (make-posn 0 1))) (make-posn 0 0)) @@ -2160,30 +2038,30 @@ for the other functions in this document (world-height 3) 'solid 'white) - (render-cell (make-cell (make-posn 0 0) false) - false - true) - (render-cell (make-cell (make-posn 0 1) false) - true - false)))] + (render-cell (make-cell (make-posn 0 0) #f) + #f + #t) + (render-cell (make-cell (make-posn 0 1) #f) + #t + #f)))] @chunk[ - (test (render-cell (make-cell (make-posn 0 0) false) false false) + (test (render-cell (make-cell (make-posn 0 0) #f) #f #f) (move-pinhole (circle circle-radius 'solid normal-color) (- circle-radius) (- circle-radius))) - (test (render-cell (make-cell (make-posn 0 0) true) false false) + (test (render-cell (make-cell (make-posn 0 0) #t) #f #f) (move-pinhole (circle circle-radius 'solid 'black) (- circle-radius) (- circle-radius))) - (test (render-cell (make-cell (make-posn 0 0) false) true false) + (test (render-cell (make-cell (make-posn 0 0) #f) #t #f) (move-pinhole (overlay (circle circle-radius 'solid normal-color) (circle (quotient circle-radius 2) 'solid on-shortest-path-color)) (- circle-radius) (- circle-radius))) - (test (render-cell (make-cell (make-posn 0 0) false) true true) + (test (render-cell (make-cell (make-posn 0 0) #f) #t #t) (move-pinhole (overlay (circle circle-radius 'solid normal-color) (circle (quotient circle-radius 2) 'solid under-mouse-color)) @@ -2208,6 +2086,150 @@ for the other functions in this document (+ circle-radius (* 2 circle-spacing 866/1000)))] +@chunk[ + (test (clack + (make-world '() (make-posn 0 0) 'playing 3 #f #f) + 1 1 'button-down) + (make-world '() (make-posn 0 0) 'playing 3 #f #f)) + (test (clack + (make-world '() (make-posn 0 0) 'playing 3 #f #f) + 1 1 'drag) + (make-world '() (make-posn 0 0) 'playing 3 #f #f)) + (test (clack + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) + 'playing + 3 + #f + #f) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) + 'move) + (make-world + (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) + 'playing + 3 + (make-posn 0 0) + #f)) + (test (clack + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) + 'playing + 3 + #f + #f) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) + 'enter) + (make-world + (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) + 'playing + 3 + (make-posn 0 0) + #f)) + (test (clack + (make-world '() (make-posn 0 0) + 'playing 3 (make-posn 0 0) #f) + 1 1 'leave) + (make-world '() (make-posn 0 0) 'playing 3 #f #f)) + + (test (clack (make-world '() (make-posn 0 0) + 'playing 3 (make-posn 0 0) #f) + 10 + 10 + 'button-down) + (make-world '() (make-posn 0 0) 'playing 3 #f #f)) + + (test (clack (make-world (list (make-cell (make-posn 0 0) #f) + (make-cell (make-posn 1 1) #f)) + (make-posn 1 1) + 'playing + 3 + (make-posn 0 0) + #f) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)) + 'button-up) + (make-world (list (make-cell (make-posn 0 0) #t) + (make-cell (make-posn 1 1) #f)) + (make-posn 1 1) + 'cat-lost + 3 + #f + #f)) + + + (test (clack (make-world '() (make-posn 0 0) + 'cat-lost 3 (make-posn 0 0) #f) + 10 + 10 + 'button-up) + (make-world '() (make-posn 0 0) + 'cat-lost 3 #f #f)) + (test (clack + (make-world + (list (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 2 0) #t) + (make-cell (make-posn 0 1) #t) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 2) #t)) + (make-posn 1 1) + 'playing + 3 + #f + #f) + (cell-center-x (make-posn 1 0)) + (cell-center-y (make-posn 1 0)) + 'button-up) + (make-world + (list (make-cell (make-posn 1 0) #t) + (make-cell (make-posn 2 0) #t) + (make-cell (make-posn 0 1) #t) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 2) #t)) + (make-posn 1 1) + 'cat-lost + 3 + #f + #f)) + + (test (clack + (make-world + (list (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 0 1) #t) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 2) #t)) + (make-posn 1 1) + 'playing + 3 + #f + #f) + (cell-center-x (make-posn 1 0)) + (cell-center-y (make-posn 1 0)) + 'button-up) + (make-world + (list (make-cell (make-posn 1 0) #t) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 0 1) #t) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 2) #t)) + (make-posn 2 0) + 'cat-won + 3 + #f + #f))] + @section{Run, program, run} @chunk[ @@ -2226,8 +2248,8 @@ for the other functions in this document (quotient board-size 2)) 'playing board-size - false - false)]) + #f + #f)]) (big-bang initial-world (on-draw render-world From 3468dc65a39535b70d1fd7fd68797735010a4f19 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Feb 2009 08:50:18 +0000 Subject: [PATCH 098/142] Welcome to a new PLT day. svn: r13812 --- 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 188a9e249d..e894815525 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "23feb2009") +#lang scheme/base (provide stamp) (define stamp "24feb2009") From 414e3b796ece9c01c26eb115325254c3a2641bc0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 24 Feb 2009 16:17:11 +0000 Subject: [PATCH 099/142] svn: r13813 --- collects/redex/private/lw-test.ss | 3 +-- collects/redex/private/reduction-semantics.ss | 2 +- collects/redex/private/run-tests.ss | 13 ++++++++++++- 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/collects/redex/private/lw-test.ss b/collects/redex/private/lw-test.ss index 2ad176bb96..109b17c9a5 100644 --- a/collects/redex/private/lw-test.ss +++ b/collects/redex/private/lw-test.ss @@ -216,8 +216,7 @@ (list (make-lw "" 0 0 1 0 #t #f) 'spring - (make-lw 'x 0 0 7 1 #f #f) - 'spring) + (make-lw 'x 0 0 7 1 #f #f)) 0 0 1 7 #t #f)) 0 0 0 8 #f #f)) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 277b4ecc1c..a3a78bb33d 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -1145,7 +1145,7 @@ (cons (reverse side-conditions) side-conditionss) (cons (reverse bindings) bindingss))] [else - (syntax-case (car stuff) (side-condition) + (syntax-case (car stuff) (where side-condition) [(side-condition tl-side-conds ...) (s-loop (cdr stuff) (append (syntax->list #'(tl-side-conds ...)) side-conditions) diff --git a/collects/redex/private/run-tests.ss b/collects/redex/private/run-tests.ss index 10dc8f5382..2fb8108de6 100644 --- a/collects/redex/private/run-tests.ss +++ b/collects/redex/private/run-tests.ss @@ -16,10 +16,21 @@ (define-runtime-path here ".") +(define (flush) + ;; these flushes are here for running under cygwin, + ;; which somehow makes mzscheme think it isn't using + ;; an interative port + (flush-output (current-error-port)) + (flush-output (current-output-port))) + (for-each (λ (test-file) + (flush) (printf "requiring ~a\n" test-file) - (dynamic-require (build-path here test-file) #f)) + (flush) + (dynamic-require (build-path here test-file) #f) + (flush)) test-files) (printf "\nWARNING: didn't run color-test.ss or subst-test.ss\n") +(flush) \ No newline at end of file From 4c02e3736dc868134db4067f143fba56bb953479 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 24 Feb 2009 16:17:35 +0000 Subject: [PATCH 100/142] svn: r13814 --- .../bmps/metafunction-Name-vertical.png | Bin 4793 -> 4795 bytes .../redex/private/bmps/metafunction-Name.png | Bin 4441 -> 4467 bytes .../redex/private/bmps/metafunction-TL.png | Bin 4613 -> 4628 bytes .../private/bmps/metafunctions-multiple.png | Bin 8029 -> 8044 bytes collects/redex/private/reduction-semantics.ss | 125 +++++++++--------- 5 files changed, 63 insertions(+), 62 deletions(-) diff --git a/collects/redex/private/bmps/metafunction-Name-vertical.png b/collects/redex/private/bmps/metafunction-Name-vertical.png index cffd3e9f29060a58b2f9bce1e90afd087df4c997..cde38b7b0f9323367c1547623680abc12e2c96c6 100644 GIT binary patch literal 4795 zcmWky2RM{}9DgNTQ7(I>v$D7Bd51I4ri>B_83~yg>5QYYLgWa^3fU{8vqhXZRAhHH zk^Y(gU+?qWz3+3+`~24Tv%ZHj#h@>o=Qs~R&;@-xZF6uB0v{vT8SpKp zT9!fC8}{y&7HG~K>{*6$ye}hT-uGQ3XlYUzDXsUF2$j=HFeMfXxrsK8u)x=z7Z+cr z>S}hJI^XDAIB%^~JDy*6oe74BzjF>w(v0NaJ$_l)Abr+1uR8cqI63rZ+aLVgP^+w8 zZtx}?fyLwT=g*%vFff?C64&kYSX1gY;p{fW7EBw061tsaGVLW;MUVgf%uP#6YiVwd zDIq1QAGmeLGiPRI?(gsSxp{eAe%mZ{w9|X#=V$zvFJEZs>Cw869v%7E#6ONZVNB?L zrEs6S%9a8O4-ao^YvX4)$6i`m+UZbGSNBj;GqSZ+EukApjrD01?cP4sj`%%pGf{b~ z{o$JRt;Aoye!YH;2n!1f4L#iW)&Q0RXW! zKaY&~3}szgT3RYrm6MYb7Z+Dm{SID+I+lDhByV}&yT`%C7PRrT?ir_o(g)NZ8g)D=nm1|Lob&_a?vHU%w=7e&}`hq zAjdKE@#Ea#R{Nj5y*EU+n3$NIogFhXGbqw^I7bTx&dpuUR$E)!+q)toBcrJ)`2KxK zEF9T)x5m%cm;VBcC$aa-*x1q0?l2G5W1`}ktSlq!?6wz|qK_sT{d0Y)=FirTKfiw2 zR=b=N`Ln$}GCqDyT3TOE502ALPfy2SFzoE?CnqN&A|lJn%h$1YKBePTgUv_T*pFV3 zXJ&318h(;&KVmT8x8-M`qNcXCvEkeLy*6=paDap@%+Cukoloq20zWx9+=3$i`!5KV zcU|nR6q~THFdRuq`J~*gA)i)7S(%BM+0W09m^Y}6g2~Ft;>Zh9BVZ2w(g-y9qq`|DFrj>gBvax@~;12?}@a90W#roVanHU^8u#>6NqDnbyb zmy?sz$P_w}n~H|U#@f24tLsHZ#*gNQw7;EUv@Bwp4q9er$yHTV&CSXpfqs4}q5EPv zvEO=nsHf#pOf4b<9%j}QM8Fu?MjJVBvQPZ}B;T3T9CQW$cF z(M4`@S&Mb%ejk^Y??RELLZ0sKS^|J1EG#U(oY;BCkC{eqQ&SnM&z(gY85#Ne?|lf~ zeOF%YI+RrxejKunTu&j9NcyQ)Z!ghNqr3}YOy_k>Oz4Yt9ko)F)q}QQ<8b}`se;5g zuz+0kuz@+B+PXRl2<-c#Qsn#VVpLRAXml^&mt{(J_PfeTjcqGHyy1a?__(+@9PY-4 zpsKVq=2t^^Yo^HWOodbf)+bMn4;4HoA*j)RC1ntytgMW~;gESr+PoA{j(S*p(MKqf zKp;d$LM2FN=Y<4T$@!;J&>KeMqAvvn1yw51Mpprall9I*jbVoY7|iq7Sel$h7n$Id z(L&eH*$)B&NaN!=3;go>Nx1s@`q|mpq@<*z2QBm0*e%IOC8;i_yyLYd8YTcp;WBgKTt_#Nq_zLFlyHZHcDRtq(1(R$= z3Z8dmWq$tt{0ulCUPf1U=erZGGt1C)K3pSJU4OT~9{{_pqeGQu@C=7b<}hbqWE8|? z_c>JoNs*D2t*fp5{{1@w%gxRGa`p2Qd~u#q3!6EBQa@P!Tm3Rmtn?ViFQ8IBhr*9D|LG;1U83YqXcZ zCJp~Y!RWbF8-14y*4Nzxvf_SLxK>>Ud(x4|V|q{JfOer!ol`Zg7A2M?7GP?wi)b+x zKFWu%Ak9Map`jt1HZP>9udi=mVKISO}==rns~d1RjA6JW{{H zuITYd5Ychz(S>ePbMw)enTrr2wZFBs6@qAK6WTO-l9IEtxi~rPtgYpPe=T-&bl_D2 z&pP3qyA+otVTo zVT^z~?w>M>Go3fdQN?i=pGLiT!@n1=7$0=>-ve*&&F${{?(SyR*5Nzz-H`g!)D&2x zfPlcC&1sZ?HWaDH|F!YK0w~vysq6=q5B~mIDnKVb_vYl~E5ln4#=gu8={X0$ZKqDZ2u4FUy-R0H8pkb^UJ_;B_t#+U%sp<#=^3r{QQd}d8pUT%~{&KJW-bh_(Zy$r12Q^ zR*)FWr~ZETPwC=t0szd&i0KPAP{^nGweR1@J$n{?Z1FZ_Z#h-a1cE?;IDHL`jje2K zdWAgcd`rf_(o9TDToy`L1(cPP*qc^XR+Lm!_*4`X*+Qf4Ty1XuucxP{$Rt;H39xB@ zZ;v0~SelLQsYr^UWphglD-+XTwo(nKw4&mFeaU=KBn>^c<8*#b4!5ou2CrP#))wwK zz*L|>OG_)vG+?4}jAaP{(h{tC)4}0#LU+pg$znZxx9f&vR9)RQnX&Ql>FMcYHTTgs zKZkP_6cn84hJknjtA8e_PVMEjQC%(b&jPY9#XQCtn3xO$NZZ-jq0wkpSJ#M$(}973 z(o&H@bi6v%FCmM;+};IY5fP^v6a%jI&L@^k|LqQOF3;95`of#|J{K95TfeAi1epgN zrGiws`^Uy=tEw*XG1FWXp@4wmXlZEy&41wU58x*!C8g+3hQAu(b{vgQmBGt<*@lLO z1_deNF*N_w^k!=a^HfUGH^N7fD61TYxV$`zO4n$-tU5>^L?RD}Iu=4N4h}-L<;_;+ z=d14yag@BetfL?$r3Xmi?|&9jR8h%Q3HqJ zoDdfWtA)qL7GvSwUu$u?1$nnc)YL9R+l&2-{st-PI?fkuvFnL4Y55BGr<=PSr7SHi zNAOY0$dryR1mNYw6@M^g_V4_U@2jgBE`Obzd`-cHWaH+Z2^=!@m0FiPnQ09*o1o#@ z+u7+K9;Sg4>g(le7nR?U!I)8+2%t66@`jf=LPA2aUcI8R+DancIwFy*A8T$e4{=6B zM8xe7b#!!6zMs;3V3d=W2Z_QzFc1Yhy|Z=i-o0W=5!=y|$iOH701$8TZuA@)r9Ky) zwY~i}^7J`9j+=*$m#C(uHu-&Jw}(A)8fyz-^!+qZA@9u_nA z>GIc-LO8<(+1QQc!uyz>+-eCB7ZM^5q=|xLeCN&`H~~23jqBG3Uny*T#;YW-h=&{> z)E$jXt~ZyK4uG`VpCa%`T|-RF$k4 z#>U>=Z2j8X>)IJ}!Cs=FynLhMF{R(~puVy39VxcIfB%|aG`BcNCTcIl8c7EMBX}Wf zLH0j*Yy1ju1E8+oQHp_qA-|yDh8Rn--qBiR`=V~RVF?qM#%B%*pBLKr>zy9X%%A z_qkM?3W-TdP7sN>xVWTy5?3kGRz_I)UgLTS!eWjSK3Z8?CJ{*_YN$iqEC0)i;={qw z>S^E|4vjt^2M5LE<>diBczFpE6AkSN8HY`I!uQG~z(ola4k9xXIfxIgpM^J*%N)c)|{ zLz@cw8^HVR>=MqN0YSpl!lJWcbq#?7Cx7MYixP9hedd9a{Z zHFt;3K#rnQY(@4rZj`)v1G<255-B|+16^odct8dr_0|DYcn%dFuAXV6%O7;}CigSl z!@VyiW>>_OYOAL_Sy@>x#_q0;i`It69gsl?1%d7N-d^8&!JWPUN=nM)*|g3%Z8W-o z0K{}{Wo784bU}6Xuih&W{BRfu%nl9?84?cW*4A%{ZlJ>il{7XsF0-kmhPX7sxvYej z5LOfaDu;T@W-mhIx)?ijH&u@xG;mL7=+8i)H9%m=yCa~h>VGQ6M@(tgk7!SPp&|dB zen?B=q~L0ZX_6>)Wmy@RSxfE|I4!UavrYt7NlD4vcyLbndw; zVomuOo>9(6tdsGva8*G;*Pf^Bk~crF(crjMLVkX{X=P{k$wek1J{}_P5@ZN$f#AoJ z$7H_v{QP_~%wEu#3jKL!0iqArDt^vUKD&cK+*st9Y7c&fozA@zM>LURyC32z_2z=0 zt_E=dvqcwEJJ%&7XuC5tB38!`_j*c1jo`M;6jYj*; z&FK~j=-+<;S1M;gKm_4Y+&V88+q-bX*0v4xS3TxrzM-xTc2-q4|9Ki|Cb^YS1GocnVI7agxn^h+Ul&2Vsvyg2uh** z>+G?eO5sP1Mh#||TKjA6ckeC>=01vA-`m?$@>_l#R`KIQaOd5cD$GL5R$C45YAGqr zUF)-%p~nX9rhrim-qZJhUpYJTHJM0-`zU7fp`W|CxxLKFs<3Y|Uw+;VJ>94MH2I^^ z$+XdDju3N!(TwkZ7)4}95_+o5PEtNmRY2mYsvA6(}phoA|NY&vL2hHQ1ri( z?BukWEkcEcggoa`lIi%mOco3gyKnzE_o7?fI!C#%19GY~Kj_+C8@i*HTQaUSt^=f=- zO7?zz=-!C>b(8Y`{{HH>Z&lQ^wFkw%JX=guI=$^j%C4+LnVGRkEG;cXwHVNKioYw5#zQ&ZDDdis7ca)g$E&Nwz|9bp*k{om+!PzDi9mGLyG}@>zQv>>c;PV0$U1T5 zaCm8Hsr5TgJ|Q7BUEQj}LJDR7KO`#%s;#J~So@rlm6a8=vvf}=IU^(EJRde8p=gY_ zzrQ~pcGeahO`W47BPJFTA0Lm!QbO`U`?SjGFJGz^k9Bu7$c#a&EXIV28o&QBl2Xd13T?mMy*&B_$<#!WfU`&IpR>>1pSo+_tc@_Tu8TBtdPx z=9ZS0=g*(l)I13eZZ#8asIK<(@wu<7`)7C8(8NSqQnFjitif&SWAfFa1YB1~1c^wj zsjfcwHFyhel;30j1c5*p8(;io-4WWBn8<(;la_v|RrKpH7`FJcxT1eic@ z+1a#w;}a9}%}=inOwP?!zIl_LoQ%HtmsScRcI66MLjdIeny~OO*t#u?lax!g$b6r?eR7yg^z|c^ISXo&Ka^JJ-1v;rP zT8#tT@BeFnO7kePdog%_%6ao^#Y{(-l2!zKdS+%~Vj?IYpsA@zUzjBV5sn%m`Vd8UAvkPgWJF(Ie|MGewzf7CwCmCD z%^IxPORzMPh3ts;g$z+eFr#b6rlzdLyS8_eniT!F^J{8$K#50IPX7MMQw$kc@v5(@ zgCIZBw=UW6>M1uWDk^H~=*~_=3dq2#;$j)k%FT%?XD6qq=xB9y^;_1hlcS?a-HV>L zFZ-AZFmc`Sbvrvf;goiRAj@W-k|E`~`g&$2CRKjMSXFXJKIDi+7fl9%T~AL>C1Tao z)L3s>e=vU!y`Ymqcg4iTz0YNl$PmS8e6SaX7WRM408EoeB>w@yYm&O^Gp)6vk-(9_Q~df42(+XbQq=zf!*A1(_ZNJaIGL_$G`2M-7l6x0x8 zU&BVlf=){_MIzTpvn?trDm;q8{u|>W*+V5boW8w%!To}yB&OWfUu0+Ov^6LT(MvPa z(~)6LTyt}CAa5!v=k0S+X6No+fkso{ zG>r81?P|>a1y{Q6EoRw>;>seRTwT%dmuYEZ$h!4)WCougAD`XQhgdgh3o9#yD_2wu z4adHGxv0EOBApUs=50~z?CgfcI>vf>09$hn?pgKq|M|K~IdggG8yg#2StV>89UblO z`(_tu3ozYG`@6lUvX^DI?(sE(nv09;-o1MuUS(kx8dq1>N0%|me2IN%I1ME^Y_SVX zZCYs=JIhspVBV4c?Isc#JV@{<0x;d!*!WpG8X+zh!OiaDXPu%&T^lutZcVwsJHjqq@>Y!)?4ScKMo9B6A=-) zd9&T`C$|mzE~u(2E7UjK$JIP&iyj zP>>5qi1NXY#`)%V@1$g8RA7LWtSl|zrqPShJfYkB`)apnqW+q7ag-fEH<{qFc+uBZMTl`o>&1{j#cMg5e zJI+pL1_$E_P5_>4gw3Le$!7%x1*Zcx?ZL9CT3;q6lzg|+Rr#Oz`l38MsF`9_ZEVg~ z2Giiw`iBQQ4*vi{hw+@MeFTLA%-w|n#4%oE=j7Bb908|glzEk(?+IjVQt8pP2Oi2W z)|-|{H@D!^5iNnYO0n>nGFtyGciSyKfvpW#f^UZCNCs(ZeKS;Yb;AQSDp+y-kn&VH#auUy}mCV_!cmbR?+F+m@X1ujK@a|txbIWT07-NBTsh86){#OiZ7+xQI(nM>;qx z10DMQ{rlRQDPVhZ^Vq}w;bH{$qqsw0Tmb6bd^PxSK)6S*a>;vMptkV%shy#FRU!kM zdg~+tolN5-krAwz=V)&~3K|XGyH#b4@W4ae<#awzc zGjy_~fnT{HDvIs0g`mfeA6Htp#kslkyD!>qre2WC;bvw=TiM(7m@DQDfjEVL71J*n zZ*G>`mewb3ZM8ZPI5MKSQY)*f@-j0w78W4L)5}W^*ud!MK8UVIcntW!&!0c1r>6rg zo#XlD4OCY?;MZJR5YS5-;4e_K&A^U*aIx(iQ|3tMUEUF3I{!H^8cQ}%Jc6vRukWvD zX!trh%7lOcZ#1HOnY(~V`JKy{kX+95sFJ!mDX25~s_yU&mm`)0StMhv(tuIaThi7MJ$H%4KfHR&Bc(}MQ z(meB+Yu(x1MYHi(nVAU_PQp6x+yw&U>FEj77_)7&U)kK8saA*={K4RV)qj601NfWF zN3BCr#B}n?i!T`tejdQr8Q=4ggPjuybV|0>ot*0h1^kkdZ!s8*ojW0jwlyMGF{C*s zXSP~;<)oLlnLeXx(JvA=qPnb}XTR+_Q3+hKb(2@m=xA+S9gFfik9kFJ@7;ji)!8O* z=aGVYRW=M9b*x^FgiM*HH7~Da5%8gW3#hX0!)X8htHy-Ds4Kf zfnW^{G2oiMeE9-I05IfSwH-xbpR2pOg6BeKwyZZ`_w@Tt*4DXL^rw_iN2!s6kzzJ^ zaq%YuDI&Dz9L8Qh06GHN&QT&`XJ-ervzs(9eW$-CY`nBXwM$qyIGQ~dm0@@UZ~hoj zH&5{ye06QDFy`;!p{$&ow6wH|u`weIv$SLnTP(O2Km305_;43k7m-Wxz;nPWvQtxg zmUkR42R7PLN{ztt_M4Q%Z!>-8Q&bmbxpw{f6|&nH`1!~k%A*?r`5hf+TT^cVv%E0^ z*6?v)U~^H?BOM(bRaHtaFu@r9e>v2crKYC3ySobt3TgzFmX})^7$^%c0V6JSKRx`Q z6--F%(Q{Sf{m6nHWF9pf?dsx!PbJ$kE%YUaEG;d+`*A=J`+vZegGEfeZYrdc4ZsG5 zk>|O0i8)VTjuPeqOyChfB%-6E2c=k(!}p29oLBN=dkaINPU5@3f4Gt9X&R`rL0X)R zHe1fge2P?RTz1p)o$cet9L&tgK$N+;Nz2P)HcnvZ0@F%m<;^{9;J*z^jGE}p3K`YZ zm=o0hV%2G%qfU-CtE{c9p>U{gIhRweU%MvEqUGr52&52&x|yJsOf0l`_%M`6#UextJh-C- zJ8l6uU>~`YFNFfERMo(GfO_h}-EW0F7$AU}rY=2MfC?*e~6hB|>q z&`*`1mw1|h72;4jVnGj5W)7}+-M-8e`>M1waC_k{ga`h$POx z>X=vW<>4enukx~<=`$+`_g_Q<{`2+oyOQ}&PqnnP-q^w4Z*93{G*VLB)7u+NYG9onEGLdQX*c=L$DH9^3P2MhrKaeT5bNdZyAP6N-Rdt+Pp;tW_zq1lHZ<(E zuc5hcfo%Q1L~c9m9d?rK8RFHCTcVSapN;abbSeur-# zJ-c3fzRPxkK<@~3Q>n;N+wD;(kR0FHYOL{Mz4BLbk!Kl zHmBEbKE&C|Ic&lM=U+c9p zpg815Wm~s4;t-Z~mhZXv{uv#o^j?5#`CGrj7D8BcacZSi%l_%f-;g+TIULRkYZ7dhs(}HFrtHfB|4L4)~N%*ZGA(dT)>w8-T$Ex_^df|m?$GI&IqGiSy=(I zG!DMN!EK`v^OD1cJZ3a;h*}X+t-0V&m2{B~5w#Lvf_MOIF zu7t*teaR4tX=ED;V|t%^{y2Y}&vQP{dA`5zb|%o9=tLw64L<;b!MKD;1Ppdu`>K(? zO+fZacCd|b*Hn^DN{5uF=tHVpOH`^YFCQ6!26ZfFLfL z&HhNj{w}F#jkvb+S9}`@=4|xS$C* zGHzg*U0bULC(~#<<+qy#!dF&SGBYy+0|UKk`Z?i(e;zu3PWmS?F_%nU?^SAJ^J^+A zE6d3pPTkzxj4{eHAU_psY-;L#pQ+u9`#U#vTO)1&WG_ z)RPFr!r~(3i<1_#yV>tj)%u$oYy&NPIDS@gi$J*j{ECc~mDQ(e_ukPm`{?UJG5@Bd zq;NQ#g@uKUjg9Q=?9?-MdADU{Wg8nCVK6q5j)ot4SNp%A%&h;eGZ+l>`}d!#3?l3A zzyBs-q1KR{4Iag3(9F!t5(_0H^kr!Y4*Ss46B{3I94w_5B8ouR+`K7Df9sd~~S-L&LR{lzh)n^;~mG1lSLX>5G}0(`VA$-QE4PC9)3ji#KOw zO+_9SIC1XQ@W_Y=0)dc{5`ew&UzL2)>wNcaY}Cbjqoq)TFN0tA#f|j1*jRZ)k0o}W z;4#a`$LCV@ro23%+l~K!0m`P?D`*yrh10jR?5ETDQVT6fT+YsBL4mBlzrW4nr2%qh z9CCi0=o*16)H5#$ZL-2Q&Y((rP0Jje(ml~j*lM`7u<-{@;oov*VjiilNNMwbOGpw4Rw#eJ8(eB)w{g;XuxT^dKop7felih2<=A=}rEtdVw28@(6J;F&@}` zMr-`$tE_IfyIx)ww6y-<<;}|+9=1_ctqCVKK3TbCYiny{WaRD5%2dDS?c<|$l0Uiw z(hqi5neb>Cci6mK^U7Ye(&&Mz#uWtf?ulVC8*SGsS7&zs=!NhA{K+UdB? z#(?#_Yn0T~>xPC0M+e&99)wMQ{(SJ@L0?Ae3V6-S%j^FAuwQG={L%T3n0VfA=le2L z3(LyR>FPQ-IZ45A_V&SxJt8)?9s>|Odh$muuE<7@MD%f)h!|?SaaKb^L-KC^{1Lpn zy^|AGTU#5**5_rnTa-a~U-iz;4vj{`cusSrle8WDUa?|bAd80JNk@dN$p@EW-Ar@s2xVL@o)hrLpOm=8`n)5E|sD*_E42DFe*Ld~^ z1q2)uJl5yz0Oa&SOqKuSg@MV*-QBJ4PoF+zvAogiQc{Yq;B|F%#^@vivgrFRO&Q*` zin6lXc6QMpnM|fPWKfxh+Y5>#GI@J@d%PU)07VL#7#Zbm9n*bl2nT|-pjZv&gqoP}!e-a!yS&mj67wX< zb=ll!cuKFP@679=Wi@fWoUy^;T$KQH$geeWYiny#((%40gS-0f?x!bf8yYU(lN5Zn zwzdY%#3}ZCKfJ$#eJ~5lgbd&<&CNd;ZH#XpN{+yYc;Hp$=6sm3v9X4RhIw{5PM%=k z?CgB%n(+(nC}VA4Vq%9ip-OY$Kb3Mt1}w(#3dI=72aCW5m@&CqRN4bXR;L;SU~6CLC^bgAxVo}3-Vq_Lp{}kDX6YpXy~NJ};(KeL z&V8h+3MXUd4Lv=-!A$Lw%~T$7={u_3GOqE=-7T49vj|c*C&TUKoGO8nbd53|S$1{i z+=F7h=)(k@Y;ru5^!V7;;5QdvJPcSW!1CU`?;ugCjx1y2cd2^ObGn+E{%<4xIH)5f zGOSO^%FNXEozd0K>05ks=FAx$E+<3N_f=$M$Bp;f4C7E6lHtYT`ueoDcMwP<(fA7U z8BYEz27{5857=cF;pBCnutY^aam*J(i}B7OYK6a+A#3m8E#^pjdwXxX5}<2ZYN|dQ zM6Z{tYmG~1>{Nqqg<}iQ(^$uk+{PlkXf=l#4|>pQ%g?nN#cg{2I6#Mxkmm64@YK{1 zu#_Wavb?16eIND zFJxjvZv1)s_heyqX_x56MdZ9%QXe?P788PLew{G3SD1LCOHj_Q0 zqy&&jc>WwWV=N=2uBL{gSw_yhi2RBm79+Nm>M4U>RA9k>!rH@pOhMKVbJspwg+`E{ zKZqtw{QOzQitE?0%J-LRQwd?=`ogzfjJ*$D|VF##S&AQCO1RuGPc1_q!W;v+`J z#;oO2^!X}R(Jp|n0XCF?f9t)*D%!X`i;s9<5O+uJB#YLgQ@DG`@c7)9%Q;)LUwgsq zrNPfl{`spk8_ab&sqWs`vuDrBZ`H+Kktug-)6>yG?a92hQrJFIM}dXUAlD1 z%hYyyS)VXIAtK^4SzAUKV8%hlZ8#He39Y>Ei@6ngtJ@??t{CrtyshYZaD&$w)*r=_f7ldNMT`NcJQ6?p!pAC?QPXe;aQZT(W+cwhvZ>1Qt;}`#kB^#pHseV z5{|@_w`>|7kEhe=Q}sR|b>3O=Ls0U|m!+kpAf$oJ9b1A<3&rdX{08>**J1`v{zXE9 zNoqd{tEsMjyYde3{zW2|dqr9>Bs8?Cu@N+l*HC`GA;l^*Bm}TZ9EH-nKMjXnc*6R} z1`{P%EK03a*UPl#uoddfuU^GF(uMzw0;Rg^u_MK-ZzvB&zMJ2(@n zmV{7b?0+W$LkarpDHTlmm~Yr-9p(R0eLb{#}yO(1P1yHHEw z=o^RoI2_K}+8T_F*tN-K8-a?sg;aD9%{O73;#$wIDRoQ1=V*_=eeEYzP$->u&Zj6% z=l8`Sm8Pesz0}0x)lK%6@`(e)N{bD~0;7P0(xm^--(NGsOft?tQ#LUA7j|5tz9onH SsUQ4k!LAxx7?m5`iTFQb=+N~5 delta 3429 zcmW+(c|26z8^0(fvL%$=B#E*w6&XngF&HUpvS!aRcGoUuB*|;vvJExXEM*HXLUu!w zEpL{w6fGEH{7%37$NA%a&gb6edCqq`zmR0)GhTiX1U&>nbp|2A5X32RTk8fUFy~v2 z8-`1VKSln|8CkF0J6#@cdm9hb-*0Tx4XY{i)v2mBAJwF@(b3JV zzfyvhW)d4;i)P`-)Kq)m4`j@yH^U;>Jwsvq}V1axd)|ggY3YQ`kOifLBd3iBx%*;Q3 z{xtbfm4iCmbFR5J4>nv09e+S(d|_Hj;}$LQ@ozj-wH|A(8KdwYBP&+ewq&bxQ-hVxOj zZJ~P*?@idt%gb+v^~8zCetyRw2S>;5o}QPj?853NnVBnIzs4seU6zq)5BepZWq?$t zQSB9lrKF{uYVLt<2y-OT_Qy;Gs?3L-ogE6k0AE__PqLP1&C%JOnt|9F`ZOgjiNHBD`9R;{?|M;ZCA8~20S zD=RNADJ8Xj{pT9P?V#wcg;3hw3LPC?Je#1V5{IUaPVfGHuyp$R@^WcON$j9bIi})g z4QyI!U_7Vg%$I2}IWvQI4GjzPaCc{9MeKFtD4aRz?CgvY=Rnld)QpafO5J^3T~`-! zbhz8-PL2|MA~-fSCLgx%_d3t8jQuk~{xoy<#Kh@jM;)DbE9qY0miTxbJ-zc7X--^taY>B9YjF zGZ43@v7S8Xz293fzWT7HDL`g|>3Kia$||R%WGR8`!pQP$b3ndY5b`v05*`mhjb8IT zLBoR%@=A(|IXOA>3=GD1TwNC)C~;|Vo2k9~Y<4aCo-=t2<}jPkymI8#I*d>9@!DtX@h(7Gki zxMZxqzoM{^&due^7dq(s_wSLBk)Q&skB_{fqN0ilDwHZ4-(`GtTO!)`%*w~i@ySUZ zA)(5uDt3rKB)0l2F-uA*xWF+tJp#}KjAZ_BuX2rh$Exim9)5m)_WIEuF@#!TRh6)y zU@oAoa-T!3W}${N`QYGSX2vQ_!4rPgw`hbq{QY}%{QUXz0Q8~iCO4%+B}O>FKeLAMu)nEn$CnjJ6<1JoS;MXZS+r@e3C&KoL0H0J+Zjx|$jz zf^kJw8qlc+f0l_&z{SHO>~P;-Lqh|LRZgKMv-29oeE$3ynW9^WKKb=4|0xFQ)Z}F4 zt5-Lj{QdnK;D&}G5+wsVvO&G~Ojz{UdwyR3{rtL@jg1X})5yrPu7w=6AfNsh7kiV1 zjdXSIHF=BH>fklYUn%T3GVGYuFR7$P-fLv~(YChpA3h+Qn_UhIYHLqgsBa z5~Mb~?iEPc*a+R($h4A<=g<>-{_fp1ZiWOclzZkM)X8mz3O#9BUUH=cj=&p$i~T0fTu`Gt~Ic)mSFHvM#- zSn$5Gu&@AV`}FBk!pQ9Gb&H|-wlG!ywTXdrncd&NU%Ysck(HIF9>%Bn2~60;q&D!! ze@#tSFlT~*2jOtIw5qvOJTn+*M@L5ym3ZbH!W%i)E)9g-&5Z$i)(1QMUd~8L8k8`s z0yeN08h-yi8Glyc;P7zw+cXmt_-mOp%j-c>Rz`+|3^QwXRu&&P(>G61eT1#wtES4? zNjy#ynF)RQKML#Wd?QMTx5dw1JsRFq=o7O~THD_iOErkf7hO!oNOtoqUkGY^Uv9xK z#G#pKpsYP4H=$$u1ipTpk@{-|KzVXs!Yw+LZar=bHxL}Nj$K~h_32A8|+_MSRLi9Zh z27^ZbEwd0ExbaC&wswhd7)%p9-aorfqy{1zXH{Yp>nvq zoZR%dC_Q}&h~F)wF^~=egO6h+`s3r{tA6{3e|F7IVuVmh$xdvju*Bo0CMHfpIptMV z?O}g*;^N}KI=cG1xVV@?aS>0wEq3Z?f4zz((1xq17mds-=H}&PcQ2*wcZxoy9qbV; z8#U8***iNs?-DJJi*8UT1txI0QJz{PhkD=^bpBLwuP+ws>F)lzvJ#jMP&JND(kpWn z6_uL^5K-QG&8xq)%FD^YzmXu5$v{!M3j!p*7Gy?KF^>-u{?_(>UZw&R0oZpeibJ#b z5}ydX<%gcdxLt{7iBy0Y1>+M)y#H;=Jp8ph7_d1P+rJNAg(C9v=YfH$s;XW*omg4v z>Eu*OBzgcIIyi{QdwYA2fKiN(+smFYGcyC=D=8__-Owl+)zjBc(0W;4zy0E(>4;l5 z@NY@RRvFyaqRg(MM1GA+E)EVcn1_TZ2}9_8ym0uZ&26CoCOLg2W8#89W#P*qFqG}a zTDbPP7E;uD9Q8AP(5a5R0cd5EdyO+89ph(n8KZEfm8Hzt}(EEsNbaRwv{3Tr&v7v^egOeR$6i%cm7yh~ z`5w&Q`u8tj3IA<9IX+rx3m>KpEYU->gI`8hKKZ5v7}hh!A(8(kUt4GSvAatdEou(f z)SmYR;UWv=HdP6jZ(Z-oouX^i9v%i9Vdu7PiOGh!vT^31lc~gu2sk1lBjXHxb*ajg6w9OP+iQEeDE zX=!P3adFBn9 zzI)IS)!*MQ3?HOuh*0%9(SFs%U*3eR?+|;?m4k)q@cp%{dT6H zprEw06dapS@(KtMYrvyqteRxCliF?`yy{sv5`#rzR)%u3QE(gB6y1St^G?1dW7Fd8 s>svJHqR98HC|O+-#gDw&*PeO=*)0%TJt$;%aGio~-!jyy)O-;2Kd`B*(*OVf diff --git a/collects/redex/private/bmps/metafunction-TL.png b/collects/redex/private/bmps/metafunction-TL.png index ce08c4c321d7b4f458640413a3bcde7fd7135b64..81a744f06dbadda70bbd4f0c00416ce9974f686f 100644 GIT binary patch delta 4273 zcmY*dc|6qJzyAtRJZ2KZBYQ;lohQp!Bl{X6Lu6OVp5YtWB74Z5Jxi9zo@L0Ao%CR= zMRwT}X58a zEwAI_uLLPVo%+Vcbd+Qlf)vfo%}=-J6e)Rb+;EggGj6c6#$qiE3=C#l#rpKor`syy zy&76t_-cpPii!$fR#Ve|1ubgr?CfM@W%JtF+Mq_S7j(;5)(ZL$6lkX;%$-i{9nF&QRUyH{^cFyLU1>QN3L(6^omtZX|ts99qX^Trr__9W)r!CFR z8%j(2hKJ*Hi>Syh>^Cm{{5jj;(cRsx9){_rKkH^qN=kb4=+VSd0=HI4Y3bbSH=iFA zp^?$=UvrNiJm9q9MhRKgJCF0-G34Xr-I!}_Ei3CE9v&Va_u8EL`0d*_CMKpR z24Mxi-Nhi7lp-N9(Pwjtd*RpjD}Q$hJZ3_)yo`&B1MpaA^JHXZroMa`CxmGYoSB`C z!GUr(Iy$B;4G9`gmYG>vTAG^jASv|$Jh7v80RaJ$l9JKU(Uw9CZ8 z@Si0HPbWLOd;kL6)YMdB?NhSg3mmVd^t`-a$?y&mXn56A;$@BNq!>Lt{m$$6@87eq zu;6a$=;(NPc@KvQ_UiLtSSq+}6>t~~BDE7z_{*I}fpZrouTL%#erxf24bG)0O* zPOxGX(Bk4o7))zP$=cRTQ*CYSz`%gV{o+;SqhB+d_&O@GU_ce^#;^ zj>9SQ@bG{N0(xw0xI&7zZ{Jo_gc|)1*2c$6O?`ZPNTGYMg~feK%SuuqMsQdqB_+@v z>WkNfglIm7eERgM)U+b-aAUHY4R*D&tFh_0xPVIPSg3Doe2|_1w5hqd8Pu2pGHVSC z(A2z~(#PE_-*WUl$_-zeDeo@@bcB!ZGSv2bfV`5}n`SpwK>Qy5kq*t%LSTZyiovjr zyUn!(SXo(_r2>(EQBfgWHHRQ4CwH~|LBWP)M^dJxr2$E+`S>xGMHa<&K86iA07FksPFT*=b#-;s)Itji z3Sc0)eC_S+Hdt(Paq%U7Bsuk8e;MS3SNZMzEH4+TNd`lhBlyT-;w0!$#R48PR4gp*9A0|-PQV*C5Gxw#8~O6jCa+0=P@ zdLADiN4Oyrvgd|}EA4t|Aw}RR!NI|)=ffO>nd?pDF-XhJ<&5{Bq`sJ!pHJo`1wH@p z;lt-B22uzJQ*Lf9(Cg{x>HYnE0RaJ8T3Vo6C;>AFYP(DZLv(a>!2M|4s@1uN9VLv6 zjCLMjGUn&!jf!-EOZfTwx1MY@nPD-Q?3XVuRpI#|MQv^Bls=$Pz)FIGf`FLjOSQldXz!}$@$4smz|6P$u!58nc-8H^k^X@JdOEro=6`~{ zi2lE~OpJ_v?D!&;_c`|WSI6KxFkyG8j|wFqA}VTNV&diDvA(tzjLaoAS5;jpXmDQu zh5nmvZRiT$ z>gr;5iZ#C>BoxzbeR}jG78ef;?_FpJGGX1|D0q9$bdP$J^+@@$|Et*8yj3Y?;3J!k z!n1K-Sxrn#q@<))js#|rPj*!uxjuG}7HDN=W-i^MpIlj45fKr2S5}s>9@$TA*pD$N z_T6yZKRAG^{J#0Mq2cez$;rQG{e^jX9esUeZr!@4rL}&1uns*3%89{X7BAX>X+Az6 zzmDtQ-mj=MChd<5Q-a^ zfCCe2Yxa=1zNM1lV!%{I%BZL)aWOIW5F6OWW@~E;NNokCwNRfIa2JUKz^|HgrOe6B zo~xS+lob_?Pe{luE5n`<2^g60v8l;|E2!rvqWi~8OMw4KuG&yG`fRgqE?F2e`}J$c zBYFk~m#BrUEg^*-WtRd@-Brpjty87j+uKR}rZfly&`lR-=fa{Q{N&_A2iSq_pQmKp z?%v+tM$dmV(Si7(07*0$QZ{epzxJu54r1jWVHpxb$W zPEH)`?Qd{#xlVpitG^aEeQ6B)9dlR-Ku}u?nt6x|rBYE*85H5;UZ4WezUy zt*@`^XlsY0M36wnFrSH%5=khJ4tq>d5l><-UFu}=`7+8iQN)evA>gzbDJeduM^7ki zw6*&|N9JBn4i0Vs&VyjFLVLhw$gQaTEG)0N8QZ{!qjKK68h=jl@;7 z5`m>LHPJIOW9QpQ=%hqM>iza^gbaWE>IoXT32$x!CSSUA35f%K36Lm|;(Or=2zwyz zf+SN~QsV65QgsA)PAf`0UKie>1r%<>uA*gWja^1cJ%v#yTe{m0B(Ud~u7Gpx*;pm-D>2+SO` zN5OX+Qm*&;Wd)MRel$D%%*>2>EGs$0EaU#Rpg=7QO;Y~GE-)Sk5q<3{DX(hk^4N)DqAP53Yjg3|u`!QAP1MDNV>U5;Gqa=BqHN8qtgmNnZ~Xiv zq@+e2B{udWx#Eu57{y&ujUXgwkJ+jEvlwN&O291VXRc{Z$=~^?W{2lm-R2zMA9`6m&x= zpk^a~lX5gHe*hGCL4gosq;_#x@9b2iOMUYuLN0{_diwOKoV>i7o7<1?-$Qu*0CE70 z8tCuGb#y#*;h5v}*Vt;eH7C?@*$M0GXejg(Wj3rOtbE>iKhsl$3NK7o-ajy{JT81P?X3@X#`>vbtJj`EQ!U zAOs`1xLA#FLt+;AbasBe#3qC!eR?&BGpXt6S|>7{f$03vv$$c8)I@URbvQtMWOX0d zXf{l2Xl#6DXScZ6n+Sr)>tU72*0|b^_DhDDEb-qwCjaa$uX;9SWo4C@mp3)Z?z)E_ zECX(X;9$&WVqt-AZ|9JZpgULwRRZ@OFsGu@0j{_Wd`YMaLzrH7@BF&DlmUASGqVU) zkQ&lbQ$Z-Eq>i$yG6UHc$ogZZ#A>760 z+e!gkB+>klr&-t(O+RKkdk3cf?uwJK(cMSKX@;M&Mo#R#G#tpaH8wV;WP9xH>DlbP z$y9i@u(A@dj~@PFZDW(OedwM)%F)WhSu1a^b4IH5%J|meZ`ID)Zr3%K9X?+rD`K1Q zM_?U3H7!sH?5S``koL$u3p#&HpRAUmt85jv=408lRhY2#M&4bGV_Q59&p##no&)F7 zXwwQjzwU&bwWK-x=iWo4XaShrCNDk<68>MnQZKY~6rYJM1Ew4W1Nt!J6DbCfPOTaQ m;n;@I|Cwm{e>(9Qh9*i?t{qozM}og5pgU^1s^!Yo!T$yI!E!;afPfScq<5qvy$A@RAiYS7L5hNkbRkj%rT5-T6aft# z=_L^`p+uUYmp9(G-db-y@-Z`+%$&2&-uoo^O4OCNTr9y*N(cmUF_f+V0%5}@Ty;nO zuIbs(<>uyQgHkIosjI7_ln^jza!N|~hCW54m!o5ZMxJ(xF74Nz9u5wU<&%GFn8=@5 z6-_f=)z;Q3gzWAg9>x;9{r%^vALwdmMAy_vGB7bQ$VKpt#gZ4TXCw|w+S z_<5IX=>83c<3FPYqZK!^2MzS~e{BUJN5vQdp{G4fzJx+k;Q)GpSFc|A`T9P0Y;0_t zZSvKWefH4P6S=)a56P*nHkJ+Z^4eS(Er_BTMGX=(H8cVO0`zNmLsdRODIhQw-MIGl z_Oi0FpjIvX=+PO4o10r|YHDzBFyz_c;bCE+kgu<=t1Dr0a#9;^=P0muFWd!*f?ZSy zz9}QaWlKv(w?-u1NXK?{b%DJhAxHganL!Wc0(#MPBV*&A8yjNhn*3Hqj*mkVdh6@! zQ&TxjOiUopln`ECUi-h$p5W>b$gNwqCMxU&N#azc7FD^WrFvIAR$NdJGe{VHSbKbY92*8wghe{6Smx4*wXB?>|V;3;@_d}6}f#AI}GvUl0X$bskV)|tAk zt%9`lZkm0#a+-#Q1^|IjX<37 zJv}@u@P1@$%+%aGu(^&lr>)Hv)P{+P@1Z)L!E#;slA^PFh1L?a8*8ZYG?o3^-A=BL z3Y#=2QWs%IQc{vkCYKZ!|DJDq{P^+A?5zAmN``18|HhMrc3T9@eX9Dw$ft0OGH#Cw zk6c-q8XCHx_=@5eO5yP6Xl-@%S2L$1Z57GL%4&6GrKqrQ|7UmH!F`V0=|%kK7=3+x z0FQ(1Ww^|fS1(_t)1h@CAC7iVC<8kWgY!_jr(& z`FXp((fHS|`+sn{-^o^#lRM0B!5|yJ;V;pFs)v9YmhyUXDD zilO_kD0=t!r_bBkPKJgIH8g17(d{+{ZpGW_BZkQchTcz)_eO~i`{Wtt}ZTsStudZ)zvz>x^Z!F z6c8F38h2@U7|}rq+Sb+<6CDlK5)%^#GH-Li;fxU6R?w$UpHL{&>FKGsxHtd{__PoO z@T8%M0uRppt{H!kgPmPgPL2{H#2#B#MoO1-b)G^Zqt0jD35(5Qu(fOSLg{?k-P_~8 z6FNCI#?E&w0!B+sy*^n*r9xa>JkP~NC&0wWxU;$0`E6@&Z=v;RjS^yLe7xOzkv4Lu zx3_n0?&P~zMKRl!+xotrn(venVXvpn7gR7hBcqbisB>rtCKY@EE#vunbyWp@0Ltlk zL`0?a*RNme>gpON4MZf_zbWo8KBT%3rLwZIQD7(p64O01HFY2U3lqUlT&>&r09{SZf{Kdx$z4!apuzy@Q9zPYQ-y_u-lhK?AZVHLPtSe2CM?tah}K?8x5Dj^|C z%F10p{f4ANOetS$NJ>d@Z0vT^v#{LpUrh!8YiQVO*=UdJ-XoLK-@Sviv{6F7eEH(l zG&?+O^iLA^g$sorKCtodSecpv(WVi=4i2(1Fg$W|V;eYk?p$JK=Ie|!!eBOmK=52> z=Yu#nJ3HUM@4ftuqc&>x^XJP_NGbo3l=9bbne8C?T33H}_x0n09RUFWlU7a)H7)J< z*ccE*9L@p1KQN$w`}S?eJpv<_C{Q|6P+Iry*;P5x)K?u2eNZ(OHZw6v(l6MUYx%2Q z3}gb(pZoXk-{k3^owZR`#`h*%wjgu_ZrDjlNnMPm6Huf2P+*Xa)IVHH6SKFgbU*=$ z0wRP)TbrA6MZ(C0*RNj-^+z#sVX@d8L*$!HG8y~=oR^nfbZBAWY&cJox}HwMz`y_y zPmr^=wzj5b584Mn~Bg-OVvcKM836&$8bgR z+xJU;tnAs}m(7^(5`d{py-EDZtW7d9Gkf6V^!&}^pUi9pDv=t-A=ho2$EKz%%gqvA z1LdcpdJfdRsk|49=nkb%iR~HCu(#(&PoR->$2)>g+}xgSwCzPiL`28L!3UdPkqPK4!^(G)M3!!RiYJg1x1BFud^_7hI3|I!pKP{xNq-0`j%&^E56fO-T zXO3Ir_O?#~^`$drfU1QBML-P#0{4MzW9FVM=_7xgKdX)b0H~`YlV%#YL~Snc@ML6V zy*bTGNlsR)9$xXglWlKr@9F4xsr3pll*UC23`hncc{fULc?AXFf_n9e|2rnv_K$0J zSO8Gj*4Ea=o_JNLlcVE!h5cDR7RZ7@mOM8cu9{YO_Ewm}aYT{|K52u7g=ou<#S|1c2LQ84ib|qGQRaM4`HXr4)$F&(F7Rc;eydxj{q{wY0RJ!8kcN z0SX5)M?+N zVB`%`1f23JHyqRH~pNQmwxr5K~;gnm6etI`}@K59(oYQ zicA(47hx(1)JTltA0Xr)J=0p?)kUii+^28%d{Q?8|6@u9zUbs#au)5r*)Qygb z2Wl7NH48?&KYK>>EPBiGiin7CpTmBa1b+PeLN`~?@lrVYuj9}P!7)w~iA3xwymD$i zaQ>-lbg>M_j`0GdwJ%`_+_hk{;H*zD+XmSZ(BIcbPcy{y1I&83yFa`+-R!@{!^4A! zG|0Zw=7oz0tc-{s}yfJ1;8{yo#c zs%x+c*BW@W0w4SFEtgfzFSz3C`HA@K!(zU4nw?SH^KiJg-({BWfpu|SZ_e8Xk_A|RlfJj^qhV)P%|DZVnzIE97+(;# zcI}$9G-p_~)@hj1D%=74vArv4keM3^zOT1{19@l(-1w^T-cPQrtn4mE=j|cw8RD}H zW05C9Q7eopRCyJSWAq7w*|&16@s9+%WF!v{4{Og!0i|JPWi_brdewlr_;;S2pFjJ& zp#F;<lu(nZX{E5U7bI`d90qE zo?2G=e{D%tRu<@50I^|`j#pMz1_lOPTwL&Ye0AMh&jf`ldsshUH9!>tw*tH}(Br(i z_ksplh%}bLEQOt&9nkE=y?GP9iTev;qXTdR8ylOQogIilW@aXT=qBpACh^xHl~zDL zoooprqBbi%iNvDBT!I)F%StztkNK=jcP~kfm50J7$&6J{gE@Z}8(CRXqk2SO<&#U! z%q%M@3Hd`bqJ6$a9KMXtopi6SthrjtTHn#Z59uWARE?;ps-}rp|3g}Y?Vl)V6?!6? zT=SDKtWq5C0^KyxbTnG`NcKy(;>Qu0w?mRiNldWI$k%y9zhKZb4l176fM!5K!e@J_ zFY|Vw4iU9tuQh|mQ5OveYptcP0NL}CvjuVjx|F#&zNedAhdWhORY3ZLQ;LCG!{J~& zJh6v6Kn7)GWWd~q5BD7$p4o`&Fro+*&ax##Gc(^^YDBJISGxpUe?Jz>DPk4Lq+V@N z3VJbJ-S0ACNzE`3WZ3g-)C?{#${D9rGIOLEbcqgF_3zLUST8GP#z`6=kAw0+fdx+z zM+2}Ff@$t{0dLHEA{_B|fxU`w{!@l}Phnvp?9M!nNDLxPOX)3i4iB@fz;jZ%Fc=j) z39l8U6mFpA9)itir%1g}1nb>+`NAW9YD`86`QIsQ_@f=mahd%J2GsFe`-v-_ztk2W zf46;ry0gBr9F^%bg)a4kR`#qTN>vbwy<}GH1HclXwN6k3gSMRvExL2=U5sAdP zbLYb4ya(RK7Gd~<{q;U+$*k|+zi(@6d+**o2!g`H!@az`;2|Mjw6?Y$K71GeuzUCJ zy1F{P2Q%nH%*m`#?&>WTFykreki-Qw43UDVe;jpSDn}id%29{#^OtvZb*ZYV3aNV{ z0n1-5wEX3lE?t^8Z=R;6riX_IoH+-}UoMFt3CmgXmqQQ~931TE=*T{o=a@9Bva)i= zjvXy6EoEh8CMG63ckV>weSCaQpFYieAQoseT5xc1b91w}Iv^nkEq{4cRaJa^yq1=h zf0>zCKtMo7Mh0>T%U>>02+i|!#flZkv4Mesi;Ih}Y8DC*mcRU8MB;3mo143F<3>@` z%mS9bTmXcx@|v0&0)c?|(Tfx;f4Kk%S>+=mBk}R^2?+_pt#&N1{N(~5WR)i*Bt%3+ zz*G52nEqn<%LPD~`O6a%6V1%b`uqDSe-uhxU0rKytFN!G(0a-VEPuHG2rYm4ojZ4S z?AU?Kc8Ek`V`HPRdN~$Y{&GPOU@nj4FQ3w2`O5*o@|TYbmcM*TgKdOD9hkkG8~g_A z=g82|5J%fxUtizAz`z767XVD<+~7A@KS!1=TXyW&G4}GUTeluMbZCN=3jj(3e|k

SM9u>Quz#yxxX7#SIvo14eS$HRs3@$qo5egHs5Muv-v%Yp?9qN1Xh zEw*MfqATwPt0l9HO6o0l$KDq5E-aW4#r0WMDM zEbtqwUteE8K0Y2U{Ns;5a&vPb2y$?6h>3}TAjr?p&&I|EzS`H z_w3n&luJuXr>Ccj=FuUD#lIXSaB*s9hkLMoxV*Qw7mk$`8XCH9-@dG@f2B+Hm(7@5IXO5u*wxjQPN#3$v?(DWf!Qc!WMouW zSQr)-1^|E{C_g{n%*>2LB1uU}IXXHbk^L`Sx-@InEa5-!zo7J6&R70&9)tBODJjLq z#*)co8jXg><9m8~;C~bZKR>@e|NOJ6s)|OV#mC3PBXc5==;PyafByXW^78V*!NC(J zPHfw@jmMz;0wTI$f@H#%Q#-%G`hWcKMy)hHt~e!#+MfcsyQ1 zL&MtI+Rx7q9=`wY5V-LuO`X%v*6F2%=CZ9UUF>=g$}IR~$2|pb(V4 z%h3#`a@2uFl}~d1a>25Uiw-oZe3J8*3zlVEbf8h?lZ;?l#zhBuRX&;d%LT|XE;`Vw z^2y9!E=ZPf(IL`>9?3*3`OEpuGA=q$YF6RPB#KZ{Qo`)pe{5r8^Xsp_BKga0Y;55C zjEfGGs(jM&mm|XbW*HY9C{_7n<}ZigH_N!_K=1HvlJl4Ion>5f zhxToZl?tq63X8N0_wycH}sqYf;8Ir?B;io^1kqX8^` zIqJajm!l3We>v*F@|U9z_SZX>zkGUwKNaBJThDgCwjynDy84sGSMO>@4 P00000NkvXXu0mjflRZaT delta 1654 zcmV-+28sFXKHWZ$7Y@t_0ssI2c7;zI0018(u_fpjf0k*I*%*SLNsdf3b(s#CjakA& zV{m86XEtUJ4~@YcJ{DX>k=c0S=<4bsRtgMW5OZc@3^BkwW1IZU#-pR7w{G3i(b0MF z;>GRTx988FUt3!XU*bKdF}$&ad5r>t3u4Y}Odt@vyu4CUQetCcH*DCz{7U94r!fZa zNJM61e-{@QGMUU`dg46_GX`HsL}p`-e!sluG{)cy@n<%M{eI)(;$FRaMI;jE&YcUF z^B#p6TZG{c_SgHQWj4Nl|GurQ?Y(>VAP5Q%5BKu&f`^2B(c0R2`0!x>!0z3<>+0(G z9?YN*F=sYLx!C&Zn^X6%4YI=Bhz&SOr%*K)klFFDRvoQog!NI|fj*jdTJC5meDl02@?AX!L(o$Ad zW@2KpbLUP(-p9x1^y$;g2V#LnqXh>CH#awns{;~(&@vlWRaM2u$7^Y6nVFdd1O#Mc ze`Fw+u*}91h0uJ`R;*Zo92*!IxVX3ot7f49VVRBpMI>&Bxw*L;H*OR~%`9MrV401lG}x{f)PdQ{xxsH3Z;lKN4RN&H z_4V})3=B-Lasj|p&JBLUcynagvSr7P9b+%wx^?TJLx(0H{M~>9h)m^=MH8?mpCME{nH1Oof6F4B`)2B~8Jv|i_ z75DAickkZ4n>TO5^0ofA#eAn5%mH z_%V{7K|w*m&dv@1(ACvNp-`w)YD`QFd`V4B?bWMSAAR(ZP#^j~(EG#AV`gLSVZ321 zEiGY}*!}zWr>CcDX=xokeAvjy=&!&2Vy>#ItBW}@H|(+1+1UvIpwVbZZGL`!@4fe) zP@nZ3(D*Hf;W4u@?_s=qe|mb7laqskgI!%+>2&(0O`8%D5}1urMn*=3g@s{ZVE_OK zg7Wk8&CJY5B$AYrl%t~~67&1grAxDB%@Y0t{|idL<$Pr}<}r-7l9EzvY%G~frqO74 zJie!=2mVJv@bmNg^Upu4s;X!-T6}ywJTfN|i9S9)=g*%nFE1Y)e;hn<;>5OX+jtDu zEg+&BCP*fHc{uYM#{0(~eNau?yhg+}_^a)zvk7_H35I%F0S(V`Cj19i)&- zrB+o{nV6W2wQN^ge_J~=G-PIG#=I2=f*=Zo($Uc|fBt;Ye#J4f3JO8#yBy76Dn}h? zRQV)lHWn=Zu;@Ue$|pIqv0(X!MF$#HKFJ7{e^_*&SLKtL*;s)5!=eMdDxb{E#)9M@ z79Ap8=#fmslG&Kw{KKLHrDherOri)SB_+(h%{DeRzyA6wf0EhQ#>NKDYz*&*$<57W zcE{v5|FGylsmdoUvoRvfZ~kG?fl`%EW@cj;e)A8D4)hM+CONY)-}#3{hqwn5Vn8gJ zjrq+#EIQDra)e3CY%DYmb*JZHG#%KV`Y>Yav%*Ln#%WRA~ zu*}BjgZ=f6Wj3DPV400k2WCk_9g?`9h9Oe^A0`2srWzw--T(jq07*qoM6N<$f<$;X A;{X5v diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index a3a78bb33d..55a7978a09 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -523,38 +523,15 @@ (define (do-leaf stx orig-name lang name-table from to extras lang-id) (let* ([lang-nts (language-id-nts lang-id orig-name)] [rw-sc (λ (pat) (rewrite-side-conditions/check-errs lang-nts orig-name #t pat))]) - (let-values ([(name fresh-vars side-conditions/withs) (process-extras stx orig-name name-table extras)]) + (let-values ([(name sides/withs/freshs) (process-extras stx orig-name name-table extras)]) (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t from)]) (with-syntax ([side-conditions-rewritten (rw-sc from)] - [lhs-w/extras (rw-sc #`(side-condition #,from #,(bind-withs side-conditions/withs #'#t)))] + [lhs-w/extras (rw-sc #`(side-condition #,from #,(bind-withs orig-name #'#t sides/withs/freshs #'#t)))] [to to] [name name] [lang lang] [(names ...) names] - [(names/ellipses ...) names/ellipses] - [(fresh-var-clauses ...) - (map (λ (fv-clause) - (syntax-case fv-clause () - [x - (identifier? #'x) - #'[x (variable-not-in main 'x)]] - [(x name) - (identifier? #'x) - #'[x (let ([the-name (term name)]) - (verify-name-ok '#,orig-name the-name) - (variable-not-in main the-name))]] - [((y) (x ...)) - #`[(y #,'...) - (variables-not-in main - (map (λ (_ignore_) 'y) - (term (x ...))))]] - [((y) (x ...) names) - #`[(y #,'...) - (let ([the-names (term names)] - [len-counter (term (x ...))]) - (verify-names-ok '#,orig-name the-names len-counter) - (variables-not-in main the-names))]])) - fresh-vars)]) + [(names/ellipses ...) names/ellipses]) #`(do-leaf-match name `side-conditions-rewritten @@ -564,29 +541,52 @@ ;; show up in the `fresh' side-conditions, the bindings for the variables ;; show up in the withs, and the withs show up in the 'fresh' side-conditions (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) - (term-let (fresh-var-clauses ...) - #,(bind-withs side-conditions/withs - #'(make-successful (term to)))))))))))) + #,(bind-withs orig-name #'main sides/withs/freshs + #'(make-successful (term to))))))))))) - ;; the withs and side-conditions come in backwards order - (define (bind-withs stx body) + ;; the withs, freshs, and side-conditions come in backwards order + (define (bind-withs orig-name main stx body) (let loop ([stx stx] [body body]) - (syntax-case stx (side-condition where) + (syntax-case stx (side-condition where fresh) [() body] [((where x e) y ...) (loop #'(y ...) #`(term-let ([x (term e)]) #,body))] [((side-condition s ...) y ...) - (loop #'(y ...) #`(and s ... #,body))]))) + (loop #'(y ...) #`(and s ... #,body))] + [((fresh x) y ...) + (identifier? #'x) + (loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))] + [((fresh x name) y ...) + (identifier? #'x) + (loop #'(y ...) + #`(term-let ([x (let ([the-name (term name)]) + (verify-name-ok '#,orig-name the-name) + (variable-not-in #,main the-name))]) + #,body))] + [((fresh (y) (x ...)) z ...) + (loop #'(z ...) + #`(term-let ([(y #,'...) + (variables-not-in #,main + (map (λ (_ignore_) 'y) + (term (x ...))))]) + #,body))] + [((fresh (y) (x ...) names) z ...) + (loop #'(z ...) + #`(term-let ([(y #,'...) + (let ([the-names (term names)] + [len-counter (term (x ...))]) + (verify-names-ok '#,orig-name the-names len-counter) + (variables-not-in #,main the-names))]) + #,body))]))) (define (process-extras stx orig-name name-table extras) (let ([the-name #f] [the-name-stx #f] - [fresh-vars '()] - [side-conditions/withs '()]) + [sides/withs/freshs '()]) (let loop ([extras extras]) (cond - [(null? extras) (values the-name fresh-vars side-conditions/withs)] + [(null? extras) (values the-name sides/withs/freshs)] [else (syntax-case (car extras) (side-condition fresh where) [name @@ -618,39 +618,40 @@ (loop (cdr extras))))] [(fresh var ...) (begin - (set! fresh-vars + (set! sides/withs/freshs (append - (map (λ (x) - (syntax-case x () - [x - (identifier? #'x) - #'x] - [(x name) - (identifier? #'x) - #'(x name)] - [((ys dots2) (xs dots1)) - (and (eq? (syntax-e #'dots1) (string->symbol "...")) - (eq? (syntax-e #'dots2) (string->symbol "..."))) - #'((ys) (xs dots1))] - [((ys dots2) (xs dots1) names) - (and (eq? (syntax-e #'dots1) (string->symbol "...")) - (eq? (syntax-e #'dots2) (string->symbol "..."))) - #'((ys) (xs dots1) names)] - [x - (raise-syntax-error orig-name - "malformed fresh variable clause" - stx - #'x)])) - (syntax->list #'(var ...))) - fresh-vars)) + (reverse + (map (λ (x) + (syntax-case x () + [x + (identifier? #'x) + #'(fresh x)] + [(x name) + (identifier? #'x) + #'(fresh x name)] + [((ys dots2) (xs dots1)) + (and (eq? (syntax-e #'dots1) (string->symbol "...")) + (eq? (syntax-e #'dots2) (string->symbol "..."))) + #'(fresh (ys) (xs dots1))] + [((ys dots2) (xs dots1) names) + (and (eq? (syntax-e #'dots1) (string->symbol "...")) + (eq? (syntax-e #'dots2) (string->symbol "..."))) + #'(fresh (ys) (xs dots1) names)] + [x + (raise-syntax-error orig-name + "malformed fresh variable clause" + stx + #'x)])) + (syntax->list #'(var ...)))) + sides/withs/freshs)) (loop (cdr extras)))] [(side-condition exp ...) (begin - (set! side-conditions/withs (cons (car extras) side-conditions/withs)) + (set! sides/withs/freshs (cons (car extras) sides/withs/freshs)) (loop (cdr extras)))] [(where x e) (begin - (set! side-conditions/withs (cons (car extras) side-conditions/withs)) + (set! sides/withs/freshs (cons (car extras) sides/withs/freshs)) (loop (cdr extras)))] [(where . x) (raise-syntax-error orig-name "malformed where clause" stx (car extras))] From 07dee9995b0ce5c39fc72b2ef8a3b265d253c2fe Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 24 Feb 2009 17:05:56 +0000 Subject: [PATCH 101/142] Uses the new sqlite ffi svn: r13816 --- collects/web-server/scribblings/tutorial/continue.scrbl | 6 ++---- .../web-server/scribblings/tutorial/examples/model-3.ss | 5 ++--- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index 24eedf89c4..3fbb67cbb0 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -948,7 +948,6 @@ So, in the next section, we'll talk about how to use an SQL database to store ou web-server/scribblings/tutorial/examples/dummy-3 web-server/scribblings/tutorial/dummy-sqlite)] @(require (for-label web-server/scribblings/tutorial/dummy-sqlite)) -@;@(require (prefix-in sqlite: (for-label (planet jaymccarthy/sqlite:3/sqlite)))) Our next task is to employ an SQL database for the blog model. We'll be using SQLite with the @schememodname[(planet jaymccarthy/sqlite:3/sqlite)] PLaneT package. We add the following to the top of our model: @@ -961,7 +960,7 @@ We now have the following bindings: @defthing[sqlite:db? (any/c . -> . boolean?)] @defthing[sqlite:open (path? . -> . sqlite:db?)] @defthing[sqlite:exec/ignore (sqlite:db? string? . -> . void)] -@defthing[sqlite:select (sqlite:db? string? . -> . (listof vector?))] +@defthing[sqlite:select (sqlite:db? string? . -> . (listof (vectorof (or/c integer? number? string? bytes? false/c))))] @defthing[sqlite:insert (sqlite:db? string? . -> . integer?)] @@ -1068,8 +1067,7 @@ The only function that creates posts is @scheme[blog-posts]: (local [(define (row->post a-row) (make-post a-blog - (string->number - (vector-ref a-row 0)))) + (vector-ref a-row 0))) (define rows (sqlite:select (blog-db a-blog) "SELECT id FROM posts"))] diff --git a/collects/web-server/scribblings/tutorial/examples/model-3.ss b/collects/web-server/scribblings/tutorial/examples/model-3.ss index 4a740fc977..3e6a28ce56 100644 --- a/collects/web-server/scribblings/tutorial/examples/model-3.ss +++ b/collects/web-server/scribblings/tutorial/examples/model-3.ss @@ -1,5 +1,5 @@ #lang scheme -(require (prefix-in sqlite: (planet jaymccarthy/sqlite:3/sqlite))) +(require (prefix-in sqlite: (planet jaymccarthy/sqlite:4))) ;; A blog is a (make-blog db) ;; where db is an sqlite database handle @@ -37,8 +37,7 @@ (local [(define (row->post a-row) (make-post a-blog - (string->number - (vector-ref a-row 0)))) + (vector-ref a-row 0))) (define rows (sqlite:select (blog-db a-blog) "SELECT id FROM posts"))] From 03f3d208ca74c85d64601d3372e47ebec38de4a4 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 24 Feb 2009 17:10:20 +0000 Subject: [PATCH 102/142] tutorial sqlite svn: r13817 --- collects/web-server/scribblings/tutorial/continue.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index 3fbb67cbb0..1c6cbba862 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -949,10 +949,10 @@ So, in the next section, we'll talk about how to use an SQL database to store ou web-server/scribblings/tutorial/dummy-sqlite)] @(require (for-label web-server/scribblings/tutorial/dummy-sqlite)) -Our next task is to employ an SQL database for the blog model. We'll be using SQLite with the @schememodname[(planet jaymccarthy/sqlite:3/sqlite)] PLaneT package. We add the following to the top of our model: +Our next task is to employ an SQL database for the blog model. We'll be using SQLite with the @schememodname[(planet jaymccarthy/sqlite:4)] PLaneT package. We add the following to the top of our model: @schemeblock[ -(require (prefix-in sqlite: (planet jaymccarthy/sqlite:3/sqlite))) +(require (prefix-in sqlite: (planet jaymccarthy/sqlite:4))) ] We now have the following bindings: From b6f3bab025921c38a985512122da1fcdb379c217 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Feb 2009 17:25:39 +0000 Subject: [PATCH 103/142] add pin-curve, pin-arrow-curve, pin-arrows-curve svn: r13818 --- collects/scribblings/reference/regexps.scrbl | 2 - collects/scribblings/slideshow/picts.scrbl | 60 ++++++++++ collects/slideshow/pict.ss | 109 ++++++++++++++++++- 3 files changed, 168 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index 9201c4bc19..ba0b5b66e6 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -12,8 +12,6 @@ @guideintro["regexp"]{regular expressions} -@local-table-of-contents[] - @deftech{Regular expressions} are specified as strings or byte strings, using the same pattern language as the Unix utility @exec{egrep} or Perl. A string-specified pattern produces a character diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index f7c2be7001..49290ba55e 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -319,6 +319,66 @@ the existing @scheme[pict] drawing, instead of on top. If @scheme[solid?] is false, then the arrowheads are hollow instead of filled.} +@defproc*[([(pin-curve [pict pict?] + [src pict-path?] + [find-src (pict? pict-path? . -> . (values real? real?))] + [dest pict-path?] + [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] + [#:arrow-size arrow-size real? 12] + [#:line-width line-width (or/c #f real?) #f] + [#:color color (or/c #f string? (is-a/c? color%)) #f] + [#:under? under? any/c #f]) + pict?] + [(pin-arrow-curve [pict pict?] + [src pict-path?] + [find-src (pict? pict-path? . -> . (values real? real?))] + [dest pict-path?] + [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] + [#:arrow-size arrow-size real? 12] + [#:line-width line-width (or/c #f real?) #f] + [#:color color (or/c #f string? (is-a/c? color%)) #f] + [#:under? under? any/c #f] + [#:solid? solid? any/c #t]) + pict?] + [(pin-arrows-curve [pict pict?] + [src pict-path?] + [find-src (pict? pict-path? . -> . (values real? real?))] + [dest pict-path?] + [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] + [#:arrow-size arrow-size real? 12] + [#:line-width line-width (or/c #f real?) #f] + [#:color color (or/c #f string? (is-a/c? color%)) #f] + [#:under? under? any/c #f] + [#:solid? solid? any/c #t]) + pict?])]{ + +Like @scheme[pin-arrow-line], etc., but draws a Bezier curve based on +@scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and +@scheme[end-pull]. + +The @scheme[start-angle] and @scheme[end-angle] arguments specify the +direction of curve at its start and end positions; if either is +@scheme[#f], it defaults to the angle of a straight line from the +start position to end position. + +The @scheme[start-pull] and @scheme[end-pull] arguments specify a kind +of momentum for the starting and ending angles; larger values preserve +the angle longer. If @scheme[start-pull] or @scheme[end-pull] is +@scheme[#f], then it is replaced with one-fourth of the distance +between the start and end points.} + @defthing[text-style/c contract?]{ A contract that matches the second argument of @scheme[text].} diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index 3a8e3c7250..df56955529 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -6,7 +6,9 @@ (rename-in texpict/utils [pin-line t:pin-line] [pin-arrow-line t:pin-arrow-line] - [pin-arrows-line t:pin-arrows-line])) + [pin-arrows-line t:pin-arrows-line]) + (only-in scheme/gui/base dc-path%) + (only-in scheme/class new send)) (define (hline w h #:segment [seg #f]) (if seg @@ -71,6 +73,110 @@ #f #f #f solid?)) p lw col under?)) + (define (pin-curve p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] + #:arrow-size [sz 12] + #:color [col #f] + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t]) + (pin-curve* #f #f p src src-find dest dest-find + sa ea sp ep sz col lw under? #t)) + + (define (pin-arrow-curve p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] + #:arrow-size [sz 12] + #:color [col #f] + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t]) + (pin-curve* #f #t p src src-find dest dest-find + sa ea sp ep sz col lw under? solid?)) + + (define (pin-arrows-curve p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] + #:arrow-size [sz 12] + #:color [col #f] + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t]) + (pin-curve* #t #t p src src-find dest dest-find + sa ea sp ep sz col lw under? solid?)) + + (define (pin-curve* start-arrow? end-arrow? p + src src-find + dest dest-find + sa ea sp ep + sz col lw + under? solid?) + (let-values ([(sx0 sy0) (src-find p src)] + [(dx0 dy0) (dest-find p dest)]) + (let* ([sa (or sa + (atan (- sy0 dy0) (- dx0 sx0)))] + [ea (or ea + (atan (- sy0 dy0) (- dx0 sx0)))] + [d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))] + [sp (or sp (* 1/4 d))] + [ep (or ep (* 1/4 d))]) + (let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)] + [dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)] + [sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)] + [sy (if start-arrow? (- sy0 (* sz (sin sa))) sy0)] + [path (new dc-path%)] + [maybe-pin-line + (lambda (arrow? p sx sy dx dy) + (if arrow? + (pin-arrow-line + sz + p + p (lambda (a b) (values sx sy)) + p (lambda (a b) (values dx dy)) + #:line-width lw + #:color col + #:under? under? + #:solid? solid?) + p))]) + (send path move-to sx sy) + (send path curve-to + (+ sx (* sp (cos sa))) + (- sy (* sp (sin sa))) + (- dx (* ep (cos ea))) + (+ dy (* ep (sin ea))) + dx + dy) + (maybe-pin-line + start-arrow? + (maybe-pin-line + end-arrow? + ((if under? pin-under pin-over) + p + 0 0 + (let* ([p (dc (lambda (dc x y) + (let ([b (send dc get-brush)]) + (send dc set-brush "white" 'transparent) + (send dc draw-path path x y) + (send dc set-brush b))) + 0 0)] + [p (if col + (colorize p col) + p)] + [p (if lw + (linewidth lw p) + p)]) + p)) + dx dy dx0 dy0) + sx sy sx0 sy0))))) + + (define (finish-pin l p lw col under?) (let* ([l (if lw (linewidth lw l) @@ -96,6 +202,7 @@ frame pict-path? pin-line pin-arrow-line pin-arrows-line + pin-curve pin-arrow-curve pin-arrows-curve (except-out (all-from-out texpict/mrpict) dash-hline dash-vline From 8dae35d46bfb71721e4633ca4966008093b622c1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Feb 2009 17:29:46 +0000 Subject: [PATCH 104/142] fix pin-curve, etc. to better match pin-line svn: r13819 --- collects/scribblings/slideshow/picts.scrbl | 12 ++++++------ collects/slideshow/pict.ss | 9 +++------ 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index 49290ba55e..144560068e 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -319,7 +319,8 @@ the existing @scheme[pict] drawing, instead of on top. If @scheme[solid?] is false, then the arrowheads are hollow instead of filled.} -@defproc*[([(pin-curve [pict pict?] +@defproc*[([(pin-curve [arrow-size real? 12] + [pict pict?] [src pict-path?] [find-src (pict? pict-path? . -> . (values real? real?))] [dest pict-path?] @@ -328,12 +329,12 @@ filled.} [#:end-angle end-angle (or/c real? #f) #f] [#:start-pull start-pull (or/c real? #f) #f] [#:end-pull end-pull (or/c real? #f) #f] - [#:arrow-size arrow-size real? 12] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f]) pict?] - [(pin-arrow-curve [pict pict?] + [(pin-arrow-curve [arrow-size real? 12] + [pict pict?] [src pict-path?] [find-src (pict? pict-path? . -> . (values real? real?))] [dest pict-path?] @@ -342,13 +343,13 @@ filled.} [#:end-angle end-angle (or/c real? #f) #f] [#:start-pull start-pull (or/c real? #f) #f] [#:end-pull end-pull (or/c real? #f) #f] - [#:arrow-size arrow-size real? 12] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f] [#:solid? solid? any/c #t]) pict?] - [(pin-arrows-curve [pict pict?] + [(pin-arrows-curve [arrow-size real? 12] + [pict pict?] [src pict-path?] [find-src (pict? pict-path? . -> . (values real? real?))] [dest pict-path?] @@ -357,7 +358,6 @@ filled.} [#:end-angle end-angle (or/c real? #f) #f] [#:start-pull start-pull (or/c real? #f) #f] [#:end-pull end-pull (or/c real? #f) #f] - [#:arrow-size arrow-size real? 12] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f] diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index df56955529..81281cdd2e 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -73,12 +73,11 @@ #f #f #f solid?)) p lw col under?)) - (define (pin-curve p + (define (pin-curve sz p src src-find dest dest-find #:start-angle [sa #f] #:end-angle [ea #f] #:start-pull [sp #f] #:end-pull [ep #f] - #:arrow-size [sz 12] #:color [col #f] #:line-width [lw #f] #:under? [under? #f] @@ -86,12 +85,11 @@ (pin-curve* #f #f p src src-find dest dest-find sa ea sp ep sz col lw under? #t)) - (define (pin-arrow-curve p + (define (pin-arrow-curve sz p src src-find dest dest-find #:start-angle [sa #f] #:end-angle [ea #f] #:start-pull [sp #f] #:end-pull [ep #f] - #:arrow-size [sz 12] #:color [col #f] #:line-width [lw #f] #:under? [under? #f] @@ -99,12 +97,11 @@ (pin-curve* #f #t p src src-find dest dest-find sa ea sp ep sz col lw under? solid?)) - (define (pin-arrows-curve p + (define (pin-arrows-curve sz p src src-find dest dest-find #:start-angle [sa #f] #:end-angle [ea #f] #:start-pull [sp #f] #:end-pull [ep #f] - #:arrow-size [sz 12] #:color [col #f] #:line-width [lw #f] #:under? [under? #f] From 5c957f915c18b7b0a026fb2a4b273443288b6c0f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Feb 2009 17:39:21 +0000 Subject: [PATCH 105/142] actually, just fold pin-curve, etc. into pin-line svn: r13820 --- collects/scribblings/slideshow/picts.scrbl | 86 +++++++------------ collects/slideshow/pict.ss | 99 +++++++++------------- 2 files changed, 71 insertions(+), 114 deletions(-) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index 144560068e..72d8a03d26 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -285,6 +285,10 @@ argument for consistency with the other functions.} [find-src (pict? pict-path? . -> . (values real? real?))] [dest pict-path?] [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f]) @@ -294,6 +298,10 @@ argument for consistency with the other functions.} [find-src (pict? pict-path? . -> . (values real? real?))] [dest pict-path?] [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f] @@ -304,6 +312,10 @@ argument for consistency with the other functions.} [find-src (pict? pict-path? . -> . (values real? real?))] [dest pict-path?] [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f] @@ -317,67 +329,27 @@ and destination of the line. If @scheme[under?] is true, then the line and arrows are added under the existing @scheme[pict] drawing, instead of on top. If @scheme[solid?] is false, then the arrowheads are hollow instead of -filled.} +filled. -@defproc*[([(pin-curve [arrow-size real? 12] - [pict pict?] - [src pict-path?] - [find-src (pict? pict-path? . -> . (values real? real?))] - [dest pict-path?] - [find-dest (pict? pict-path? . -> . (values real? real?))] - [#:start-angle start-angle (or/c real? #f) #f] - [#:end-angle end-angle (or/c real? #f) #f] - [#:start-pull start-pull (or/c real? #f) #f] - [#:end-pull end-pull (or/c real? #f) #f] - [#:line-width line-width (or/c #f real?) #f] - [#:color color (or/c #f string? (is-a/c? color%)) #f] - [#:under? under? any/c #f]) - pict?] - [(pin-arrow-curve [arrow-size real? 12] - [pict pict?] - [src pict-path?] - [find-src (pict? pict-path? . -> . (values real? real?))] - [dest pict-path?] - [find-dest (pict? pict-path? . -> . (values real? real?))] - [#:start-angle start-angle (or/c real? #f) #f] - [#:end-angle end-angle (or/c real? #f) #f] - [#:start-pull start-pull (or/c real? #f) #f] - [#:end-pull end-pull (or/c real? #f) #f] - [#:line-width line-width (or/c #f real?) #f] - [#:color color (or/c #f string? (is-a/c? color%)) #f] - [#:under? under? any/c #f] - [#:solid? solid? any/c #t]) - pict?] - [(pin-arrows-curve [arrow-size real? 12] - [pict pict?] - [src pict-path?] - [find-src (pict? pict-path? . -> . (values real? real?))] - [dest pict-path?] - [find-dest (pict? pict-path? . -> . (values real? real?))] - [#:start-angle start-angle (or/c real? #f) #f] - [#:end-angle end-angle (or/c real? #f) #f] - [#:start-pull start-pull (or/c real? #f) #f] - [#:end-pull end-pull (or/c real? #f) #f] - [#:line-width line-width (or/c #f real?) #f] - [#:color color (or/c #f string? (is-a/c? color%)) #f] - [#:under? under? any/c #f] - [#:solid? solid? any/c #t]) - pict?])]{ +The @scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and +@scheme[end-pull] arguments control the curve of the line: -Like @scheme[pin-arrow-line], etc., but draws a Bezier curve based on -@scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and -@scheme[end-pull]. +@itemize[ -The @scheme[start-angle] and @scheme[end-angle] arguments specify the -direction of curve at its start and end positions; if either is -@scheme[#f], it defaults to the angle of a straight line from the -start position to end position. + @item{The @scheme[start-angle] and @scheme[end-angle] arguments + specify the direction of curve at its start and end positions; + if either is @scheme[#f], it defaults to the angle of a + straight line from the start position to end position.} -The @scheme[start-pull] and @scheme[end-pull] arguments specify a kind -of momentum for the starting and ending angles; larger values preserve -the angle longer. If @scheme[start-pull] or @scheme[end-pull] is -@scheme[#f], then it is replaced with one-fourth of the distance -between the start and end points.} + @item{The @scheme[start-pull] and @scheme[end-pull] arguments specify + a kind of momentum for the starting and ending angles; larger + values preserve the angle longer. If @scheme[start-pull] or + @scheme[end-pull] is @scheme[#f], then it is replaced with + one-fourth of the distance between the start and end points.} + +] + +The defaults produce a straight line.} @defthing[text-style/c contract?]{ diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index 81281cdd2e..aac07f9fb0 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -42,62 +42,24 @@ (list? p) (andmap pict? p)))) - (define (pin-line p src find-src dest find-dest - #:line-width [lw #f] + (define (pin-line sz p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] #:color [col #f] - #:under? [under? #f]) - (finish-pin (launder (t:pin-line (ghost p) - src find-src - dest find-dest)) - p lw col under?)) + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t]) + (if (not (or sa ea)) + (finish-pin (launder (t:pin-line (ghost p) + src src-find + dest dest-find)) + p lw col under?) + (pin-curve* #f #f p src src-find dest dest-find + sa ea sp ep sz col lw under? #t))) - (define (pin-arrow-line sz p src find-src dest find-dest - #:line-width [lw #f] - #:color [col #f] - #:under? [under? #f] - #:solid? [solid? #t]) - (finish-pin (launder (t:pin-arrow-line sz (ghost p) - src find-src - dest find-dest - #f #f #f solid?)) - p lw col under?)) - - (define (pin-arrows-line sz p src find-src dest find-dest - #:line-width [lw #f] - #:color [col #f] - #:under? [under? #f] - #:solid? [solid? #t]) - (finish-pin (launder (t:pin-arrows-line sz (ghost p) - src find-src - dest find-dest - #f #f #f solid?)) - p lw col under?)) - - (define (pin-curve sz p - src src-find - dest dest-find - #:start-angle [sa #f] #:end-angle [ea #f] - #:start-pull [sp #f] #:end-pull [ep #f] - #:color [col #f] - #:line-width [lw #f] - #:under? [under? #f] - #:solid? [solid? #t]) - (pin-curve* #f #f p src src-find dest dest-find - sa ea sp ep sz col lw under? #t)) - - (define (pin-arrow-curve sz p - src src-find - dest dest-find - #:start-angle [sa #f] #:end-angle [ea #f] - #:start-pull [sp #f] #:end-pull [ep #f] - #:color [col #f] - #:line-width [lw #f] - #:under? [under? #f] - #:solid? [solid? #t]) - (pin-curve* #f #t p src src-find dest dest-find - sa ea sp ep sz col lw under? solid?)) - - (define (pin-arrows-curve sz p + (define (pin-arrow-line sz p src src-find dest dest-find #:start-angle [sa #f] #:end-angle [ea #f] @@ -106,9 +68,33 @@ #:line-width [lw #f] #:under? [under? #f] #:solid? [solid? #t]) - (pin-curve* #t #t p src src-find dest dest-find - sa ea sp ep sz col lw under? solid?)) + (if (not (or sa ea)) + (finish-pin (launder (t:pin-arrow-line sz (ghost p) + src src-find + dest dest-find + #f #f #f solid?)) + p lw col under?) + (pin-curve* #f #t p src src-find dest dest-find + sa ea sp ep sz col lw under? solid?))) + (define (pin-arrows-line sz p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] + #:color [col #f] + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t]) + (if (not sa ea) + (finish-pin (launder (t:pin-arrows-line sz (ghost p) + src src-find + dest dest-find + #f #f #f solid?)) + p lw col under?) + (pin-curve* #t #t p src src-find dest dest-find + sa ea sp ep sz col lw under? solid?))) + (define (pin-curve* start-arrow? end-arrow? p src src-find dest dest-find @@ -199,7 +185,6 @@ frame pict-path? pin-line pin-arrow-line pin-arrows-line - pin-curve pin-arrow-curve pin-arrows-curve (except-out (all-from-out texpict/mrpict) dash-hline dash-vline From b2ae4264e3c227330e4cfcae4eceb431abbbf289 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Feb 2009 17:47:24 +0000 Subject: [PATCH 106/142] change pin-line pull to a ratio svn: r13821 --- collects/scribblings/slideshow/picts.scrbl | 16 +++++++--------- collects/slideshow/pict.ss | 4 ++-- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index 72d8a03d26..cae5e309f1 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -287,8 +287,8 @@ argument for consistency with the other functions.} [find-dest (pict? pict-path? . -> . (values real? real?))] [#:start-angle start-angle (or/c real? #f) #f] [#:end-angle end-angle (or/c real? #f) #f] - [#:start-pull start-pull (or/c real? #f) #f] - [#:end-pull end-pull (or/c real? #f) #f] + [#:start-pull start-pull real? 1/4] + [#:end-pull end-pull real? 1/4] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f]) @@ -300,8 +300,8 @@ argument for consistency with the other functions.} [find-dest (pict? pict-path? . -> . (values real? real?))] [#:start-angle start-angle (or/c real? #f) #f] [#:end-angle end-angle (or/c real? #f) #f] - [#:start-pull start-pull (or/c real? #f) #f] - [#:end-pull end-pull (or/c real? #f) #f] + [#:start-pull start-pull real? 1/4] + [#:end-pull end-pull real? 1/4] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f] @@ -314,8 +314,8 @@ argument for consistency with the other functions.} [find-dest (pict? pict-path? . -> . (values real? real?))] [#:start-angle start-angle (or/c real? #f) #f] [#:end-angle end-angle (or/c real? #f) #f] - [#:start-pull start-pull (or/c real? #f) #f] - [#:end-pull end-pull (or/c real? #f) #f] + [#:start-pull start-pull real? 1/4] + [#:end-pull end-pull real? 1/4] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f] @@ -343,9 +343,7 @@ The @scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and @item{The @scheme[start-pull] and @scheme[end-pull] arguments specify a kind of momentum for the starting and ending angles; larger - values preserve the angle longer. If @scheme[start-pull] or - @scheme[end-pull] is @scheme[#f], then it is replaced with - one-fourth of the distance between the start and end points.} + values preserve the angle longer.} ] diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index aac07f9fb0..adc304e0d8 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -108,8 +108,8 @@ [ea (or ea (atan (- sy0 dy0) (- dx0 sx0)))] [d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))] - [sp (or sp (* 1/4 d))] - [ep (or ep (* 1/4 d))]) + [sp (* (or sp 1/4) d)] + [ep (* (or ep 1/4) d)]) (let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)] [dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)] [sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)] From 0ee3f53230e674a463aadbd9256ce2fbdb64542d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 24 Feb 2009 22:22:35 +0000 Subject: [PATCH 107/142] schemeunit svn: r13822 --- collects/xml/test.ss | 225 ++++++++++++++++++------------------------- 1 file changed, 95 insertions(+), 130 deletions(-) diff --git a/collects/xml/test.ss b/collects/xml/test.ss index 5d6f27ec58..0c70113b8d 100644 --- a/collects/xml/test.ss +++ b/collects/xml/test.ss @@ -1,138 +1,103 @@ -;; run these tests with: -;; % mzscheme --require test.ss +#lang scheme +(require (planet schematics/schemeunit:3) + (planet schematics/schemeunit:3/text-ui) + xml) -(module test mzscheme - (require xml/main - scheme/list - scheme/port) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; utils - ;; - - ;; test-bad-read-input : format-str str -> void - ;; First argument is the input, second is the error message - (define (test-bad-read-input format-str err-string) - (let ([str (format format-str)]) - (with-handlers ([exn:xml? - (lambda (x) - (unless (equal? (exn-message x) err-string) - (report-err format-str (exn-message x) err-string)))]) - (read-xml (open-input-string str)) - (report-err str "no error" err-string)))) - - ;; tests-failed : number - ;; incremened for each test that fails - (define tests-failed 0) - - ;; report-err : string string string -> void - ;; reports an error in the test suite - ;; increments tests-failed. - (define (report-err test got expected) - (set! tests-failed (+ tests-failed 1)) - (printf "FAILED test: ~a~n got: ~a~n expected: ~a~n" - test got expected)) - - ;; done : -> void - ;; prints out a message saying the tests are done. - ;; if any tests failed, prints a message saying how many - (define (done) - (if (= tests-failed 0) - (printf "All tests passed~n") - (printf "~a tests failed~n" tests-failed))) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; reader error tests - ;; - - (test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") - (test-bad-read-input "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") - (test-bad-read-input - "" - "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") - (test-bad-read-input - "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") - - (test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") - (test-bad-read-input "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") - (test-bad-read-input - "~n" - "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") - (test-bad-read-input - "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'") - - ;; permissive? - (with-handlers ([exn? - (lambda (exn) - (regexp-match #rx"Expected content," (exn-message exn)))]) - (report-err "Non-permissive" (xml->xexpr #f) "Exception")) - - (with-handlers ([exn? - (lambda (exn) - (report-err "Permissive" "Exception" "#f"))]) - (parameterize ([permissive? #t]) - (let ([tmp (xml->xexpr #f)]) - (when tmp - (report-err "Permissive" tmp "#f"))))) - - ;; doctype - (let () - (define source-string #< void +;; First argument is the input, second is the error message +(define (test-bad-read-input format-str err-string) + (define str (format format-str)) + (test-exn + str + (lambda (x) + (and (exn:xml? x) + (equal? (exn-message x) err-string))) + (lambda () + (read-xml (open-input-string str))))) + +(define xml-tests + (test-suite + "XML" + + (test-suite + "read-xml" + (test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") + (test-bad-read-input "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") + (test-bad-read-input + "" + "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") + (test-bad-read-input + "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") + + (test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") + (test-bad-read-input "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") + (test-bad-read-input + "~n" + "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") + (test-bad-read-input + "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")) + + (test-suite + "xml->xexpr" + (test-exn + "Non-permissive" + (lambda (exn) + (and (exn? exn) + (regexp-match #rx"Expected content," (exn-message exn)))) + (lambda () + (xml->xexpr #f))) + + (test-false + "Permissive" + (parameterize ([permissive? #t]) + (xml->xexpr #f)))) + + (test-suite + "DOCTYPE" + + (let () + (define source-string #< END - ) - - (define source-document - (read-xml (open-input-string source-string))) - (define result-string - (with-output-to-string (lambda () (write-xml source-document)))) - (define expected-string #< END - ) - (unless (string=? expected-string result-string) - (report-err "DOCTYPE dropping" - result-string - expected-string))) - - - ;; pis - (define a-pi (make-p-i #f #f "foo" "bar")) - (define a-p (make-prolog empty #f)) - (define a-p/pi (make-prolog (list a-pi) #f)) - (define a-d0 - (make-document a-p (make-element #f #f 'html empty empty) - empty)) - (define a-d1 - (make-document a-p (make-element #f #f 'html empty empty) - (list a-pi))) - (define a-d2 - (make-document a-p/pi (make-element #f #f 'html empty empty) - (list a-pi))) - - (define (test-string=? test result expected) - (unless (string=? result expected) - (report-err test result expected))) - - (test-string=? "Display XML w/o pis" - (with-output-to-string (lambda () (display-xml a-d0))) - "\n") - (test-string=? "Display XML w/ pi in doc-misc" - (with-output-to-string (lambda () (display-xml a-d1))) - "\n\n") - (test-string=? "Display XML w/ pi in doc-misc and prolog" - (with-output-to-string (lambda () (display-xml a-d2))) - "\n\n\n") - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; done - ;; - (done)) + ) + (test-equal? + "DOCTYPE dropping" result-string expected-string))) + + (let () + (define a-pi (make-p-i #f #f "foo" "bar")) + (define a-p (make-prolog empty #f)) + (define a-p/pi (make-prolog (list a-pi) #f)) + (define a-d0 + (make-document a-p (make-element #f #f 'html empty empty) + empty)) + (define a-d1 + (make-document a-p (make-element #f #f 'html empty empty) + (list a-pi))) + (define a-d2 + (make-document a-p/pi (make-element #f #f 'html empty empty) + (list a-pi))) + (test-suite + "PIs" + (test-equal? "Display XML w/o pis" + (with-output-to-string (lambda () (display-xml a-d0))) + "\n") + (test-equal? "Display XML w/ pi in doc-misc" + (with-output-to-string (lambda () (display-xml a-d1))) + "\n\n") + (test-equal? "Display XML w/ pi in doc-misc and prolog" + (with-output-to-string (lambda () (display-xml a-d2))) + "\n\n\n"))))) + +(run-tests xml-tests) \ No newline at end of file From c909836ba81681a97d52e85bfd73ec904bae85d0 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 24 Feb 2009 22:22:49 +0000 Subject: [PATCH 108/142] new tests svn: r13823 --- collects/{ => tests}/xml/test.ss | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename collects/{ => tests}/xml/test.ss (100%) diff --git a/collects/xml/test.ss b/collects/tests/xml/test.ss similarity index 100% rename from collects/xml/test.ss rename to collects/tests/xml/test.ss From b95292a7be2fba61e8646d036aad3ee702b10f48 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 24 Feb 2009 23:09:22 +0000 Subject: [PATCH 109/142] tests svn: r13824 --- collects/tests/xml/test.ss | 349 +++++++++++++++++++++++++++++-------- 1 file changed, 281 insertions(+), 68 deletions(-) diff --git a/collects/tests/xml/test.ss b/collects/tests/xml/test.ss index 0c70113b8d..bdbe645cd2 100644 --- a/collects/tests/xml/test.ss +++ b/collects/tests/xml/test.ss @@ -5,7 +5,7 @@ ;; test-bad-read-input : format-str str -> void ;; First argument is the input, second is the error message -(define (test-bad-read-input format-str err-string) +(define (test-read-xml/exn format-str err-string) (define str (format format-str)) (test-exn str @@ -15,89 +15,302 @@ (lambda () (read-xml (open-input-string str))))) +(define (document->list xml) + (list 'make-document + (prolog->list (document-prolog xml)) + (element->list (document-element xml)) + (list* 'list (map misc->list (document-misc xml))))) +(define (prolog->list p) + (list* 'make-prolog + (list* 'list (map misc->list (prolog-misc p))) + (dtd->list (prolog-dtd p)) + (map misc->list (prolog-misc2 p)))) +(define (dtd->list d) + (if d + (list 'make-document-type + (document-type-name d) + (external-dtd->list (document-type-external d)) + (document-type-inlined d)) + #f)) +(define (external-dtd->list d) + (cond + [(external-dtd/system? d) + (list 'make-external-dtd/system (external-dtd-system d))] + [(external-dtd/public? d) + (list 'make-external-dtd/public (external-dtd-system d) (external-dtd/public-public d))] + [(external-dtd? d) + (list 'make-external-dtd (external-dtd-system d))])) +(define (element->list e) + (list 'make-element + (source->list e) + (list 'quote (element-name e)) + (list* 'list (map attribute->list (element-attributes e))) + (list* 'list (map content->list (element-content e))))) +(define (misc->list e) + (cond + [(comment? e) + (comment->list e)] + [(p-i? e) + (p-i->list e)])) +(define (content->list e) + (cond + [(pcdata? e) (pcdata->list e)] + [(element? e) (element->list e)] + [(entity? e) (entity->list e)] + [(comment? e) (comment->list e)] + [(cdata? e) (cdata->list e)])) +(define (attribute->list e) + (list 'make-attribute + (source->list e) + (attribute-name e) + (attribute-value e))) +(define (entity->list e) + (list 'make-entity + (source->list e) + (list 'quote (entity-text e)))) +(define (pcdata->list e) + (list 'make-pcdata + (source->list e) + (pcdata-string e))) +(define (cdata->list e) + (list 'make-cdata + (source->list e) + (cdata-string e))) +(define (p-i->list e) + (list 'make-p-i + (source->list e) + (p-i-target-name e) + (p-i-instruction e))) +(define (comment->list e) + (list 'make-comment + (comment-text e))) +(define (source->list e) + (list 'make-source + (location->list (source-start e)) + (location->list (source-stop e)))) +(define (location->list e) + (if (symbol? e) + e + (list 'make-location + (location-line e) + (location-char e) + (location-offset e)))) + + +(define (test-read-xml str xml) + (test-equal? str (document->list (read-xml (open-input-string str))) xml)) + +(define (test-xexpr? xe) + (test-not-false (format "~S" xe) (xexpr? xe))) +(define (test-not-xexpr? xe) + (test-false (format "~S" xe) (xexpr? xe))) + (define xml-tests (test-suite "XML" (test-suite - "read-xml" - (test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") - (test-bad-read-input "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") - (test-bad-read-input - "" - "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") - (test-bad-read-input - "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") + "Datatypes" + (test-suite + "xexpr" + (test-xexpr? "string") + (test-xexpr? (list 'a (list (list 'href "#")) "content")) + (test-xexpr? (list 'p "one" "two" "three")) + (test-xexpr? 'nbsp) + (test-xexpr? 10) + (test-xexpr? (make-cdata #f #f "unquoted ")) + (test-xexpr? (make-comment "Comment!")) + (test-xexpr? (make-pcdata #f #f "quoted ")) + + (test-not-xexpr? +) + (test-not-xexpr? #f)) - (test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") - (test-bad-read-input "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") - (test-bad-read-input - "~n" - "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") - (test-bad-read-input - "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")) + (test-not-false "xexpr/c" (contract? xexpr/c)) + + (test-not-false "document" (document? (make-document (make-prolog empty #f) (make-element #f #f 'br empty empty) empty))) + + (test-not-false "prolog" (prolog? (make-prolog empty #f))) + (let ([c1 (make-comment "c1")] + [c2 (make-comment "c2")]) + (test-equal? "prolog" (prolog-misc2 (make-prolog empty #f c1 c2)) + (list c1 c2))) + + (test-not-false "document-type" (document-type? (make-document-type 'name (make-external-dtd "string") #f))) + + (test-not-false "external-dtd" (external-dtd? (make-external-dtd "string"))) + (test-not-false "external-dtd/public" (external-dtd/public? (make-external-dtd/public "string" "public"))) + (test-not-false "external-dtd/system" (external-dtd/system? (make-external-dtd/system "string"))) + + (test-not-false "element" (element? (make-element #f #f 'br empty empty))) + + (test-not-false "content? pcdata" (content? (make-pcdata #f #f "pcdata"))) + (test-not-false "content? element" (content? (make-element #f #f 'br empty empty))) + (test-not-false "content? entity" (content? (make-entity #f #f 'nbsp))) + (test-not-false "content? comment" (content? (make-comment "string"))) + (test-not-false "content? cdata" (content? (make-cdata #f #f "cdata"))) + + (test-not-false "attribute" (attribute? (make-attribute #f #f 'name "value"))) + + (test-not-false "entity symbol" (entity? (make-entity #f #f 'nbsp))) + (test-not-false "entity number" (entity? (make-entity #f #f 10))) + + (test-not-false "pcdata" (pcdata? (make-pcdata #f #f "string"))) + + (test-not-false "cdata" (cdata? (make-cdata #f #f "string"))) + + (test-not-false "p-i" (p-i? (make-p-i #f #f "target" "instruction"))) + + (test-not-false "comment" (comment? (make-comment "text"))) + + (test-not-false "source" (source? (make-source 'start 'stop))) + (test-not-false "source" (source? (make-source (make-location 1 2 3) 'stop))) + (test-not-false "source" (source? (make-source 'start (make-location 1 2 3)))) + (test-not-false "source" (source? (make-source (make-location 1 2 3) (make-location 4 5 6)))) + + (test-not-false "exn:invalid-xexpr" (exn:invalid-xexpr? (make-exn:invalid-xexpr "string" (current-continuation-marks) 'nbsp)))) (test-suite - "xml->xexpr" - (test-exn - "Non-permissive" - (lambda (exn) - (and (exn? exn) - (regexp-match #rx"Expected content," (exn-message exn)))) - (lambda () - (xml->xexpr #f))) + "Reading and Writing XML" - (test-false - "Permissive" - (parameterize ([permissive? #t]) - (xml->xexpr #f)))) + (test-suite + "read-xml" + (test-read-xml/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") + (test-read-xml/exn "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") + (test-read-xml/exn + "" + "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") + (test-read-xml/exn + "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") + + (test-read-xml/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") + (test-read-xml/exn "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") + (test-read-xml/exn + "~n" + "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") + (test-read-xml/exn + "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'") + + (test-read-xml + "hi there!" + '(make-document + (make-prolog (list) #f) + (make-element + (make-source (make-location 1 0 1) (make-location 1 33 34)) + 'doc + (list) + (list + (make-element + (make-source (make-location 1 5 6) (make-location 1 20 21)) + 'bold + (list) + (list (make-pcdata (make-source (make-location 1 11 12) (make-location 1 13 14)) "hi"))) + (make-pcdata (make-source (make-location 1 20 21) (make-location 1 27 28)) " there!"))) + (list))) + + (test-read-xml + "inner" + '(make-document + (make-prolog (list) #f) + (make-element + (make-source (make-location 1 0 1) (make-location 1 21 22)) + 'a + (list (make-attribute (make-source (make-location 1 3 4) (make-location 1 11 12)) href "#")) + (list (make-pcdata (make-source (make-location 1 12 13) (make-location 1 17 18)) "inner"))) + (list))) + + (test-read-xml + " " + '(make-document + (make-prolog (list) #f) + (make-element + (make-source (make-location 1 0 1) (make-location 1 19 20)) + 'root + (list) + (list (make-entity (make-source (make-location 1 6 7) (make-location 1 12 13)) 'nbsp))) + (list))) + + (test-read-xml + "(" + '(make-document + (make-prolog (list) #f) + (make-element + (make-source (make-location 1 0 1) (make-location 1 18 19)) + 'root + (list) + (list (make-entity (make-source (make-location 1 6 7) (make-location 1 11 12)) '40))) + (list))) + + (test-read-xml + "
" + '(make-document + (make-prolog (list) #f) + (make-element (make-source (make-location 1 16 17) (make-location 1 22 23)) 'br (list) (list)) + (list)))) + + ) + + + (test-suite + "xml->xexpr" + (test-exn + "Non-permissive" + (lambda (exn) + (and (exn? exn) + (regexp-match #rx"Expected content," (exn-message exn)))) + (lambda () + (xml->xexpr #f))) - (test-suite - "DOCTYPE" - - (let () - (define source-string #<xexpr #f)))) + + (test-suite + "DOCTYPE" + + (let () + (define source-string #< END - ) - - (define source-document - (read-xml (open-input-string source-string))) - (define result-string - (with-output-to-string (lambda () (write-xml source-document)))) - (define expected-string #< END - ) - (test-equal? - "DOCTYPE dropping" result-string expected-string))) - - (let () - (define a-pi (make-p-i #f #f "foo" "bar")) - (define a-p (make-prolog empty #f)) - (define a-p/pi (make-prolog (list a-pi) #f)) - (define a-d0 - (make-document a-p (make-element #f #f 'html empty empty) - empty)) - (define a-d1 - (make-document a-p (make-element #f #f 'html empty empty) - (list a-pi))) - (define a-d2 - (make-document a-p/pi (make-element #f #f 'html empty empty) - (list a-pi))) - (test-suite - "PIs" - (test-equal? "Display XML w/o pis" - (with-output-to-string (lambda () (display-xml a-d0))) - "\n") - (test-equal? "Display XML w/ pi in doc-misc" - (with-output-to-string (lambda () (display-xml a-d1))) - "\n\n") - (test-equal? "Display XML w/ pi in doc-misc and prolog" - (with-output-to-string (lambda () (display-xml a-d2))) - "\n\n\n"))))) + ) + (test-equal? + "DOCTYPE dropping" result-string expected-string))) + + (let () + (define a-pi (make-p-i #f #f "foo" "bar")) + (define a-p (make-prolog empty #f)) + (define a-p/pi (make-prolog (list a-pi) #f)) + (define a-d0 + (make-document a-p (make-element #f #f 'html empty empty) + empty)) + (define a-d1 + (make-document a-p (make-element #f #f 'html empty empty) + (list a-pi))) + (define a-d2 + (make-document a-p/pi (make-element #f #f 'html empty empty) + (list a-pi))) + (test-suite + "PIs" + (test-equal? "Display XML w/o pis" + (with-output-to-string (lambda () (display-xml a-d0))) + "\n") + (test-equal? "Display XML w/ pi in doc-misc" + (with-output-to-string (lambda () (display-xml a-d1))) + "\n\n") + (test-equal? "Display XML w/ pi in doc-misc and prolog" + (with-output-to-string (lambda () (display-xml a-d2))) + "\n\n\n"))))) (run-tests xml-tests) \ No newline at end of file From 20fa57d6d0019a94425a5cf69fdae63c4bde2397 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 24 Feb 2009 23:09:58 +0000 Subject: [PATCH 110/142] tests svn: r13825 --- collects/tests/xml/test.ss | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/tests/xml/test.ss b/collects/tests/xml/test.ss index bdbe645cd2..51079b2515 100644 --- a/collects/tests/xml/test.ss +++ b/collects/tests/xml/test.ss @@ -246,6 +246,8 @@ (make-prolog (list) #f) (make-element (make-source (make-location 1 16 17) (make-location 1 22 23)) 'br (list) (list)) (list)))) + + ; XXX need more ) From 20af4fe7d4c6aaa3b78edc3547bc1ed3009fb56c Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 24 Feb 2009 23:12:07 +0000 Subject: [PATCH 111/142] small typo in iworlds svn: r13826 --- collects/2htdp/private/universe.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss index f1dd4b08bd..47c4da41ce 100644 --- a/collects/2htdp/private/universe.ss +++ b/collects/2htdp/private/universe.ss @@ -228,9 +228,9 @@ (define-struct iworld (in out name info) #:transparent) ;; World = (make-iworld IPort OPort Symbol [Listof Sexp]) -(define iworld1 (make-iworld (current-input-port) (current-output-port) 'sk '())) -(define iworld2 (make-iworld (current-input-port) (current-output-port) 'mf '())) -(define iworld3 (make-iworld (current-input-port) (current-output-port) 'rf '())) +(define iworld1 (make-iworld (current-input-port) (current-output-port) 'iworld1 '())) +(define iworld2 (make-iworld (current-input-port) (current-output-port) 'iworld2 '())) +(define iworld3 (make-iworld (current-input-port) (current-output-port) 'iworld3 '())) (define (iworld=? u v) (check-arg 'iworld=? (iworld? u) 'iworld "first" u) From 757b1e84d2693d3ed21bf482bee2024acb2089dd Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Wed, 25 Feb 2009 01:05:45 +0000 Subject: [PATCH 112/142] bug in list of world managements fixed svn: r13827 --- collects/2htdp/private/universe.ss | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss index 47c4da41ce..a1aaec2b45 100644 --- a/collects/2htdp/private/universe.ss +++ b/collects/2htdp/private/universe.ss @@ -146,7 +146,6 @@ (close-output-port (iworld-out p)) (close-input-port (iworld-in p)) (send gui add (format "~a !! closed port" (iworld-name p))) - (set! iworlds (remq p iworlds)) (pdisconnect p) (cont)) From adf5c9342a9f4422ce54e5b55f42b4a20277eb83 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Feb 2009 08:50:21 +0000 Subject: [PATCH 113/142] Welcome to a new PLT day. svn: r13828 --- 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 e894815525..22f815ec9b 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "24feb2009") +#lang scheme/base (provide stamp) (define stamp "25feb2009") From 7c0273bf47fc739a2cd27ae91ebf8cfe45435ef6 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 25 Feb 2009 12:24:19 +0000 Subject: [PATCH 114/142] new tests svn: r13829 --- collects/tests/xml/test.ss | 480 ++++++++++++++++++++++++---------- collects/tests/xml/to-list.ss | 84 ++++++ 2 files changed, 420 insertions(+), 144 deletions(-) create mode 100644 collects/tests/xml/to-list.ss diff --git a/collects/tests/xml/test.ss b/collects/tests/xml/test.ss index 51079b2515..ddb78df326 100644 --- a/collects/tests/xml/test.ss +++ b/collects/tests/xml/test.ss @@ -1,105 +1,46 @@ #lang scheme (require (planet schematics/schemeunit:3) (planet schematics/schemeunit:3/text-ui) - xml) + xml + "to-list.ss") ;; test-bad-read-input : format-str str -> void ;; First argument is the input, second is the error message -(define (test-read-xml/exn format-str err-string) +(define ((mk-test-read-xml/exn read-xml) format-str err-string) (define str (format format-str)) (test-exn str (lambda (x) - (and (exn:xml? x) - (equal? (exn-message x) err-string))) + (regexp-match (regexp-quote err-string) (exn-message x))) (lambda () (read-xml (open-input-string str))))) -(define (document->list xml) - (list 'make-document - (prolog->list (document-prolog xml)) - (element->list (document-element xml)) - (list* 'list (map misc->list (document-misc xml))))) -(define (prolog->list p) - (list* 'make-prolog - (list* 'list (map misc->list (prolog-misc p))) - (dtd->list (prolog-dtd p)) - (map misc->list (prolog-misc2 p)))) -(define (dtd->list d) - (if d - (list 'make-document-type - (document-type-name d) - (external-dtd->list (document-type-external d)) - (document-type-inlined d)) - #f)) -(define (external-dtd->list d) - (cond - [(external-dtd/system? d) - (list 'make-external-dtd/system (external-dtd-system d))] - [(external-dtd/public? d) - (list 'make-external-dtd/public (external-dtd-system d) (external-dtd/public-public d))] - [(external-dtd? d) - (list 'make-external-dtd (external-dtd-system d))])) -(define (element->list e) - (list 'make-element - (source->list e) - (list 'quote (element-name e)) - (list* 'list (map attribute->list (element-attributes e))) - (list* 'list (map content->list (element-content e))))) -(define (misc->list e) - (cond - [(comment? e) - (comment->list e)] - [(p-i? e) - (p-i->list e)])) -(define (content->list e) - (cond - [(pcdata? e) (pcdata->list e)] - [(element? e) (element->list e)] - [(entity? e) (entity->list e)] - [(comment? e) (comment->list e)] - [(cdata? e) (cdata->list e)])) -(define (attribute->list e) - (list 'make-attribute - (source->list e) - (attribute-name e) - (attribute-value e))) -(define (entity->list e) - (list 'make-entity - (source->list e) - (list 'quote (entity-text e)))) -(define (pcdata->list e) - (list 'make-pcdata - (source->list e) - (pcdata-string e))) -(define (cdata->list e) - (list 'make-cdata - (source->list e) - (cdata-string e))) -(define (p-i->list e) - (list 'make-p-i - (source->list e) - (p-i-target-name e) - (p-i-instruction e))) -(define (comment->list e) - (list 'make-comment - (comment-text e))) -(define (source->list e) - (list 'make-source - (location->list (source-start e)) - (location->list (source-stop e)))) -(define (location->list e) - (if (symbol? e) - e - (list 'make-location - (location-line e) - (location-char e) - (location-offset e)))) - - +(define test-read-xml/exn (mk-test-read-xml/exn read-xml)) (define (test-read-xml str xml) (test-equal? str (document->list (read-xml (open-input-string str))) xml)) +(define test-syntax:read-xml/exn (mk-test-read-xml/exn syntax:read-xml)) +(define (test-syntax:read-xml str xml) + (test-equal? str (syntax->datum (syntax:read-xml (open-input-string str))) xml)) + +(define test-read-xml/element/exn (mk-test-read-xml/exn read-xml/element)) +(define (test-read-xml/element str xml) + (test-equal? str (element->list (read-xml/element (open-input-string str))) xml)) + +(define test-syntax:read-xml/element/exn (mk-test-read-xml/exn syntax:read-xml/element)) +(define (test-syntax:read-xml/element str xml) + (test-equal? str (syntax->datum (read-xml/element (open-input-string str))) xml)) + +(define (test-write-xml str) + (test-equal? str (with-output-to-string (lambda () (write-xml (read-xml (open-input-string str))))) str)) +(define (test-write-xml/content str) + (test-equal? str (with-output-to-string (lambda () (write-xml/content (document-element (read-xml (open-input-string str)))))) str)) + +(define (test-display-xml str res) + (test-equal? str (with-output-to-string (lambda () (display-xml (read-xml (open-input-string str))))) res)) +(define (test-display-xml/content str res) + (test-equal? str (with-output-to-string (lambda () (display-xml/content (document-element (read-xml (open-input-string str)))))) res)) + (define (test-xexpr? xe) (test-not-false (format "~S" xe) (xexpr? xe))) (define (test-not-xexpr? xe) @@ -190,6 +131,9 @@ (test-read-xml/exn "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'") + (test-read-xml/exn "" "read-xml: parse-error: expected root element - received #") + (test-read-xml/exn "

" "read-xml: parse-error: extra stuff at end of document #") + (test-read-xml "hi there!" '(make-document @@ -245,74 +189,322 @@ '(make-document (make-prolog (list) #f) (make-element (make-source (make-location 1 16 17) (make-location 1 22 23)) 'br (list) (list)) - (list)))) + (list))) + + ; XXX need more read-xml tests + + ) - ; XXX need more - + (test-suite + "read-xml/element" + (test-read-xml/element/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") + (test-read-xml/element/exn "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") + (test-read-xml/element/exn + "" + "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") + (test-read-xml/element/exn + "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") + + (test-read-xml/element/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") + (test-read-xml/element/exn "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") + (test-read-xml/element/exn + "~n" + "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") + (test-read-xml/element/exn + "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'") + + (test-read-xml/element/exn "" "read-xml: parse-error: expected root element - received #") + + (test-read-xml/element + "

" + '(make-element (make-source (make-location 1 0 1) (make-location 1 6 7)) 'br (list) (list))) + + (test-read-xml/element + "hi there!" + '(make-element + (make-source (make-location 1 0 1) (make-location 1 33 34)) + 'doc + (list) + (list + (make-element + (make-source (make-location 1 5 6) (make-location 1 20 21)) + 'bold + (list) + (list (make-pcdata (make-source (make-location 1 11 12) (make-location 1 13 14)) "hi"))) + (make-pcdata (make-source (make-location 1 20 21) (make-location 1 27 28)) " there!")))) + + (test-read-xml/element + "inner" + '(make-element + (make-source (make-location 1 0 1) (make-location 1 21 22)) + 'a + (list (make-attribute (make-source (make-location 1 3 4) (make-location 1 11 12)) href "#")) + (list (make-pcdata (make-source (make-location 1 12 13) (make-location 1 17 18)) "inner")))) + + (test-read-xml/element + " " + '(make-element + (make-source (make-location 1 0 1) (make-location 1 19 20)) + 'root + (list) + (list (make-entity (make-source (make-location 1 6 7) (make-location 1 12 13)) 'nbsp)))) + + (test-read-xml/element + "(" + '(make-element + (make-source (make-location 1 0 1) (make-location 1 18 19)) + 'root + (list) + (list (make-entity (make-source (make-location 1 6 7) (make-location 1 11 12)) '40)))) + + (test-read-xml/element/exn + "
" + "read-xml: parse-error: expected root element - received #") + + ; XXX need more read-xml/element tests + + ) + + (test-suite + "syntax:read-xml" + (test-syntax:read-xml/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") + (test-syntax:read-xml/exn "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") + (test-syntax:read-xml/exn + "" + "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") + (test-syntax:read-xml/exn + "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") + + (test-syntax:read-xml/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") + (test-syntax:read-xml/exn "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") + (test-syntax:read-xml/exn + "~n" + "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") + (test-syntax:read-xml/exn + "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'") + + (test-syntax:read-xml/exn "" "read-xml: parse-error: expected root element - received #") + (test-syntax:read-xml/exn "

" "read-xml: parse-error: extra stuff at end of document #") + + (test-syntax:read-xml + "hi there!" + '(doc () (bold () "hi") " there!")) + + (test-syntax:read-xml + "inner" + '(a ([href "#"]) "inner")) + + (test-syntax:read-xml + " " + '(root () nbsp)) + + (test-syntax:read-xml + "(" + '(root () 40)) + + (test-syntax:read-xml/exn + "
" + "read-xml: parse-error: expected root element - received #f") + + ; XXX need more syntax:read-xml tests + + ) + + (test-suite + "syntax:read-xml/element" + (test-syntax:read-xml/element/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") + (test-syntax:read-xml/element/exn "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") + (test-syntax:read-xml/element/exn + "" + "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") + (test-syntax:read-xml/element/exn + "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") + + (test-syntax:read-xml/element/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") + (test-syntax:read-xml/element/exn "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") + (test-syntax:read-xml/element/exn + "~n" + "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") + (test-syntax:read-xml/element/exn + "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'") + + (test-syntax:read-xml/element/exn "" "read-xml: parse-error: expected root element - received #") + (test-syntax:read-xml/element + "

" + '(br ())) + + (test-syntax:read-xml/element + "hi there!" + '(doc () (bold () "hi") " there!")) + + (test-syntax:read-xml/element + "inner" + '(a ([href "#"]) "inner")) + + (test-syntax:read-xml/element + " " + '(root () nbsp)) + + (test-syntax:read-xml/element + "(" + '(root () 40)) + + (test-syntax:read-xml/element/exn + "
" + "read-xml: parse-error: expected root element - received #f") + + ; XXX need more syntax:read-xml/element tests + + ) + + (test-suite + "write-xml" + (test-write-xml "hi there!") + (test-write-xml "inner") + (test-write-xml " ") + (test-write-xml "(") + (test-write-xml "
") + ; XXX need more write-xml tests + ) + + (test-suite + "write-xml/content" + (test-write-xml/content "hi there!") + (test-write-xml/content "inner") + (test-write-xml/content " ") + (test-write-xml/content "(") + (test-write-xml/content "
") + ; XXX need more write-xml/content tests + ) + + (test-suite + "display-xml" + (test-display-xml "hi there!" "\n\n \n hi\n \n there!\n") + (test-display-xml "inner" "\n\n inner\n") + (test-display-xml " " "\n \n") + (test-display-xml "(" "\n(\n") + (test-display-xml "
" "\n
") + ; XXX need more display-xml tests + ) + + (test-suite + "display-xml/content" + (test-display-xml/content "hi there!" "\n\n \n hi\n \n there!\n") + (test-display-xml/content "inner" "\n\n inner\n") + (test-display-xml/content " " "\n \n") + (test-display-xml/content "(" "\n(\n") + (test-display-xml/content "
" "\n
") + ; XXX need more display-xml/content tests + ) ) - - - (test-suite - "xml->xexpr" - (test-exn - "Non-permissive" - (lambda (exn) - (and (exn? exn) - (regexp-match #rx"Expected content," (exn-message exn)))) - (lambda () - (xml->xexpr #f))) - (test-false - "Permissive" - (parameterize ([permissive? #t]) - (xml->xexpr #f)))) - - (test-suite - "DOCTYPE" + (test-suite + "XML and X-expression Conversions" + + ; XXX permissive? + + ; XXX xml->xexpr + + ; XXX xexpr->string + + ; XXX eliminate-whitespace + + ; XXX validate-xexpr + + ; XXX correct-xexpr? + + ) - (let () - (define source-string #<xexpr" + (test-exn + "Non-permissive" + (lambda (exn) + (and (exn? exn) + (regexp-match #rx"Expected content," (exn-message exn)))) + (lambda () + (xml->xexpr #f))) + + (test-false + "Permissive" + (parameterize ([permissive? #t]) + (xml->xexpr #f)))) + + (test-suite + "DOCTYPE" + + (let () + (define source-string #< END - ) - - (define source-document - (read-xml (open-input-string source-string))) - (define result-string - (with-output-to-string (lambda () (write-xml source-document)))) - (define expected-string #< END - ) - (test-equal? - "DOCTYPE dropping" result-string expected-string))) - - (let () - (define a-pi (make-p-i #f #f "foo" "bar")) - (define a-p (make-prolog empty #f)) - (define a-p/pi (make-prolog (list a-pi) #f)) - (define a-d0 - (make-document a-p (make-element #f #f 'html empty empty) - empty)) - (define a-d1 - (make-document a-p (make-element #f #f 'html empty empty) - (list a-pi))) - (define a-d2 - (make-document a-p/pi (make-element #f #f 'html empty empty) - (list a-pi))) - (test-suite - "PIs" - (test-equal? "Display XML w/o pis" - (with-output-to-string (lambda () (display-xml a-d0))) - "\n") - (test-equal? "Display XML w/ pi in doc-misc" - (with-output-to-string (lambda () (display-xml a-d1))) - "\n\n") - (test-equal? "Display XML w/ pi in doc-misc and prolog" - (with-output-to-string (lambda () (display-xml a-d2))) - "\n\n\n"))))) + ) + (test-equal? + "DOCTYPE dropping" result-string expected-string))) + + (let () + (define a-pi (make-p-i #f #f "foo" "bar")) + (define a-p (make-prolog empty #f)) + (define a-p/pi (make-prolog (list a-pi) #f)) + (define a-d0 + (make-document a-p (make-element #f #f 'html empty empty) + empty)) + (define a-d1 + (make-document a-p (make-element #f #f 'html empty empty) + (list a-pi))) + (define a-d2 + (make-document a-p/pi (make-element #f #f 'html empty empty) + (list a-pi))) + (test-suite + "PIs" + (test-equal? "Display XML w/o pis" + (with-output-to-string (lambda () (display-xml a-d0))) + "\n") + (test-equal? "Display XML w/ pi in doc-misc" + (with-output-to-string (lambda () (display-xml a-d1))) + "\n\n") + (test-equal? "Display XML w/ pi in doc-misc and prolog" + (with-output-to-string (lambda () (display-xml a-d2))) + "\n\n\n")))))) (run-tests xml-tests) \ No newline at end of file diff --git a/collects/tests/xml/to-list.ss b/collects/tests/xml/to-list.ss new file mode 100644 index 0000000000..f34a3eaba2 --- /dev/null +++ b/collects/tests/xml/to-list.ss @@ -0,0 +1,84 @@ +#lang scheme +(require xml) +(provide (all-defined-out)) + +(define (document->list xml) + (list 'make-document + (prolog->list (document-prolog xml)) + (element->list (document-element xml)) + (list* 'list (map misc->list (document-misc xml))))) +(define (prolog->list p) + (list* 'make-prolog + (list* 'list (map misc->list (prolog-misc p))) + (dtd->list (prolog-dtd p)) + (map misc->list (prolog-misc2 p)))) +(define (dtd->list d) + (if d + (list 'make-document-type + (document-type-name d) + (external-dtd->list (document-type-external d)) + (document-type-inlined d)) + #f)) +(define (external-dtd->list d) + (cond + [(external-dtd/system? d) + (list 'make-external-dtd/system (external-dtd-system d))] + [(external-dtd/public? d) + (list 'make-external-dtd/public (external-dtd-system d) (external-dtd/public-public d))] + [(external-dtd? d) + (list 'make-external-dtd (external-dtd-system d))])) +(define (element->list e) + (list 'make-element + (source->list e) + (list 'quote (element-name e)) + (list* 'list (map attribute->list (element-attributes e))) + (list* 'list (map content->list (element-content e))))) +(define (misc->list e) + (cond + [(comment? e) + (comment->list e)] + [(p-i? e) + (p-i->list e)])) +(define (content->list e) + (cond + [(pcdata? e) (pcdata->list e)] + [(element? e) (element->list e)] + [(entity? e) (entity->list e)] + [(comment? e) (comment->list e)] + [(cdata? e) (cdata->list e)])) +(define (attribute->list e) + (list 'make-attribute + (source->list e) + (attribute-name e) + (attribute-value e))) +(define (entity->list e) + (list 'make-entity + (source->list e) + (list 'quote (entity-text e)))) +(define (pcdata->list e) + (list 'make-pcdata + (source->list e) + (pcdata-string e))) +(define (cdata->list e) + (list 'make-cdata + (source->list e) + (cdata-string e))) +(define (p-i->list e) + (list 'make-p-i + (source->list e) + (p-i-target-name e) + (p-i-instruction e))) +(define (comment->list e) + (list 'make-comment + (comment-text e))) +(define (source->list e) + (list 'make-source + (location->list (source-start e)) + (location->list (source-stop e)))) +(define (location->list e) + (if (symbol? e) + e + (list 'make-location + (location-line e) + (location-char e) + (location-offset e)))) \ No newline at end of file From 9657528134c366d07fc62daab10e8d2e58c14c5f Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 25 Feb 2009 12:37:35 +0000 Subject: [PATCH 115/142] plist svn: r13830 --- collects/tests/xml/test.ss | 123 +++++++++++++++++++++++++++---------- 1 file changed, 91 insertions(+), 32 deletions(-) diff --git a/collects/tests/xml/test.ss b/collects/tests/xml/test.ss index ddb78df326..434c2106d1 100644 --- a/collects/tests/xml/test.ss +++ b/collects/tests/xml/test.ss @@ -2,6 +2,7 @@ (require (planet schematics/schemeunit:3) (planet schematics/schemeunit:3/text-ui) xml + xml/plist "to-list.ss") ;; test-bad-read-input : format-str str -> void @@ -222,40 +223,40 @@ (test-read-xml/element "hi there!" '(make-element - (make-source (make-location 1 0 1) (make-location 1 33 34)) - 'doc - (list) - (list - (make-element - (make-source (make-location 1 5 6) (make-location 1 20 21)) - 'bold - (list) - (list (make-pcdata (make-source (make-location 1 11 12) (make-location 1 13 14)) "hi"))) - (make-pcdata (make-source (make-location 1 20 21) (make-location 1 27 28)) " there!")))) + (make-source (make-location 1 0 1) (make-location 1 33 34)) + 'doc + (list) + (list + (make-element + (make-source (make-location 1 5 6) (make-location 1 20 21)) + 'bold + (list) + (list (make-pcdata (make-source (make-location 1 11 12) (make-location 1 13 14)) "hi"))) + (make-pcdata (make-source (make-location 1 20 21) (make-location 1 27 28)) " there!")))) (test-read-xml/element "inner" '(make-element - (make-source (make-location 1 0 1) (make-location 1 21 22)) - 'a - (list (make-attribute (make-source (make-location 1 3 4) (make-location 1 11 12)) href "#")) - (list (make-pcdata (make-source (make-location 1 12 13) (make-location 1 17 18)) "inner")))) + (make-source (make-location 1 0 1) (make-location 1 21 22)) + 'a + (list (make-attribute (make-source (make-location 1 3 4) (make-location 1 11 12)) href "#")) + (list (make-pcdata (make-source (make-location 1 12 13) (make-location 1 17 18)) "inner")))) (test-read-xml/element " " '(make-element - (make-source (make-location 1 0 1) (make-location 1 19 20)) - 'root - (list) - (list (make-entity (make-source (make-location 1 6 7) (make-location 1 12 13)) 'nbsp)))) + (make-source (make-location 1 0 1) (make-location 1 19 20)) + 'root + (list) + (list (make-entity (make-source (make-location 1 6 7) (make-location 1 12 13)) 'nbsp)))) (test-read-xml/element "(" '(make-element - (make-source (make-location 1 0 1) (make-location 1 18 19)) - 'root - (list) - (list (make-entity (make-source (make-location 1 6 7) (make-location 1 11 12)) '40)))) + (make-source (make-location 1 0 1) (make-location 1 18 19)) + 'root + (list) + (list (make-entity (make-source (make-location 1 6 7) (make-location 1 11 12)) '40)))) (test-read-xml/element/exn "
" @@ -430,16 +431,74 @@ ) - (test-suite - "PList Library" - - ; XXX plist-dict? - - ; XXX read-plist - - ; XXX write-plist - - ) + (local [(define example + `(dict (assoc-pair "first-key" + "just a string with some whitespace in it") + (assoc-pair "second-key" + (false)) + (assoc-pair "third-key" + (dict )) + (assoc-pair "fourth-key" + (dict (assoc-pair "inner-key" + (real 3.432)))) + (assoc-pair "fifth-key" + (array (integer 14) + "another string" + (true))) + (assoc-pair "sixth-key" + (array)))) + (define example-str #< + +first-keyjust a string with some whitespace in itsecond-keythird-keyfourth-keyinner-key3.432fifth-key14another stringsixth-key +END + )] + (test-suite + "PList Library" + + (test-not-false + "plist-dict?" + (plist-dict? + example)) + (test-false + "plist-dict?" + (plist-dict? + `(p "Hey"))) + (test-false + "plist-dict?" + (plist-dict? + `(dict (p "Hey")))) + (test-false + "plist-dict?" + (plist-dict? + `(dict (assoc-pair "key" 2 3)))) + (test-false + "plist-dict?" + (plist-dict? + `(dict (assoc-pair 1 2)))) + (test-false + "plist-dict?" + (plist-dict? + `(dict (assoc-pair "key" #f)))) + + (test-equal? "read-plist" + (read-plist (open-input-string example-str)) + example) + + (test-equal? "write-plist" + (with-output-to-string + (lambda () + (write-plist example (current-output-port)))) + example-str) + + (local [(define (test-plist-round-trip plist) + (define-values (in out) (make-pipe)) + (write-plist plist out) + (close-output-port out) + (test-equal? (format "~S" plist) (read-plist in) plist))] + (test-plist-round-trip example)) + + )) (test-suite "Legacy tests" From 51b867459b4eea801e9314765ff5e8ab8e8387da Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 25 Feb 2009 12:37:43 +0000 Subject: [PATCH 116/142] moving tests svn: r13831 --- collects/xml/plist.ss | 34 ---------------------------------- 1 file changed, 34 deletions(-) diff --git a/collects/xml/plist.ss b/collects/xml/plist.ss index d7b7d27b20..6e06e75a3f 100644 --- a/collects/xml/plist.ss +++ b/collects/xml/plist.ss @@ -180,39 +180,5 @@ (error 'read-plist "xml expression is not a plist: ~a" content)) (collapse-dict (caddr content)))) - ;; TEST - - '(define my-dict - `(dict (assoc-pair "first-key" - "just a string - with some whitespace in it") - (assoc-pair "second-key" - (false)) - (assoc-pair "third-key" - (dict )) - (assoc-pair "fourth-key" - (dict (assoc-pair "inner-key" - (real 3.432)))) - (assoc-pair "fifth-key" - (array (integer 14) - "another string" - (true))) - (assoc-pair "sixth-key" - (array)))) - - '(call-with-output-file "/Users/clements/tmp.plist" - (lambda (port) - (write-plist my-dict port)) - 'truncate) - - '(define new-dict - (call-with-input-file "/Users/clements/tmp.plist" - (lambda (port) - (read-plist port)))) - - '(equal? new-dict my-dict) - - ;; END OF TEST - (provide plist-dict? read-plist) (provide/contract [write-plist (plist-dict? output-port? . -> . void?)])) From b901c9769f85c8589fd494b570e6d57f0f1e7506 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Feb 2009 13:18:49 +0000 Subject: [PATCH 117/142] avoid planet dependency svn: r13832 --- collects/tests/xml/info.ss | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 collects/tests/xml/info.ss diff --git a/collects/tests/xml/info.ss b/collects/tests/xml/info.ss new file mode 100644 index 0000000000..a073420a94 --- /dev/null +++ b/collects/tests/xml/info.ss @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define compile-omit-paths 'all) From 4fd43c7d9a7816bd0b960288234cbd5213b2d710 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 25 Feb 2009 15:30:29 +0000 Subject: [PATCH 118/142] made the special identifier <*> count as main, if it is present svn: r13833 --- collects/scribble/lp/lang/lang.ss | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss index 6a2d95116c..b3eb79042e 100644 --- a/collects/scribble/lp/lang/lang.ss +++ b/collects/scribble/lp/lang/lang.ss @@ -6,6 +6,7 @@ (require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase)) (begin-for-syntax + (define first-id #f) (define main-id #f) (define (mapping-get mapping id) (free-identifier-mapping-get mapping id (lambda () '()))) @@ -16,7 +17,8 @@ (define (get-chunk id) (map syntax-local-introduce (mapping-get chunks id))) (define (add-to-chunk! id exprs) - (unless main-id (set! main-id id)) + (unless first-id (set! first-id id)) + (when (eq? (syntax-e id) '<*>) (set! main-id id)) (free-identifier-mapping-put! chunk-groups id (cons (syntax-local-introduce id) (mapping-get chunk-groups id))) @@ -26,8 +28,13 @@ (define-syntax (tangle stx) (define chunk-mentions '()) + (define stupid-internal-definition-sytnax + (unless main-id + (raise-syntax-error 'scribble/lp "no chunks"))) (define body - (let loop ([block (get-chunk main-id)]) + (let loop ([block (if main-id + (get-chunk main-id) + (get-chunk first-id))]) (append-map (lambda (expr) (if (identifier? expr) From 2a2697c20a91c23daf5a78a74fbd71da533596f0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Feb 2009 15:52:02 +0000 Subject: [PATCH 119/142] no need for string->immutable-string svn: r13834 --- collects/handin-server/checker.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index 1176dfbaaa..c5fd648bba 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -334,8 +334,7 @@ (if (memq unknown vals) exn (apply (struct-type-make-constructor struct-type) - (string->immutable-string - (format "while evaluating ~s:\n ~a" expr (car vals))) + (format "while evaluating ~s:\n ~a" expr (car vals)) (cdr vals)))) exn)))) (with-handlers ([exn? reraise]) (eval expr))) From f799ade23831875dc16b40eec6040470b6209739 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Feb 2009 16:05:10 +0000 Subject: [PATCH 120/142] fix scribble/lp chunk linking svn: r13835 --- collects/scribble/private/lp.ss | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/collects/scribble/private/lp.ss b/collects/scribble/private/lp.ss index 229afa89a7..092d59aa3b 100644 --- a/collects/scribble/private/lp.ss +++ b/collects/scribble/private/lp.ss @@ -7,18 +7,21 @@ ;; maps chunk identifiers to a counter, so we can distinguish multiple uses ;; of the same name (define chunk-numbers (make-free-identifier-mapping)) - (define (get-chunk-number id) + (define (get-chunk-number id install?) (let ([n (add1 (free-identifier-mapping-get chunk-numbers id (lambda () 0)))]) - (free-identifier-mapping-put! chunk-numbers id n) - n))) + (when install? + (free-identifier-mapping-put! chunk-numbers id n)) + n)) + (define (register-chunk-name name) + (get-chunk-number name #t))) (define-syntax (chunk stx) (syntax-case stx () [(_ name expr ...) ;; no need for more error checking, using chunk for the code will do that (identifier? #'name) - (let ([n (get-chunk-number #'name)] + (let ([n (get-chunk-number (syntax-local-introduce #'name) #f)] [str (symbol->string (syntax-e #'name))]) (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) @@ -43,9 +46,9 @@ #`(begin (require (for-label for-label-mod ... ...)) ;; why does this happen twice? - #; (define-syntax name (make-element-id-transformer (lambda (stx) #'(chunkref name)))) + (begin-for-syntax (register-chunk-name #'name)) (make-splice (list (make-toc-element #f From 97b3e6ba96f54859896d4907d946670315476f92 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Feb 2009 17:13:28 +0000 Subject: [PATCH 121/142] * Wrap a `#%top-interaction' around evaluations. No way to configure or disable it yet. * Instantiate scheme/class into teaching language sandboxes, to make it possible to use the test engine (still no way to report errors yet). * Some minor formatting and renames svn: r13836 --- collects/scheme/sandbox.ss | 49 +++++++++++++++++++++----------------- 1 file changed, 27 insertions(+), 22 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 92c53027e1..df7b0766c8 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -408,10 +408,9 @@ [orig-ns (namespace-anchor->empty-namespace anchor)] [mods (cdr specs)]) (parameterize ([current-namespace orig-ns]) - (for-each (lambda (mod) (dynamic-require mod #f)) mods)) + (for ([mod (in-list mods)]) (dynamic-require mod #f))) (parameterize ([current-namespace new-ns]) - (for-each (lambda (ms) (namespace-attach-module orig-ns ms)) - mods)) + (for ([mod (in-list mods)]) (namespace-attach-module orig-ns mod))) new-ns)) (define (extract-required language requires) @@ -457,7 +456,7 @@ (list source n (and n 0) n (and n 1))) r))))])))) -(define ((init-for-language language)) +(define ((init-hook-for-language language)) (cond [(or (not (pair? language)) (not (eq? 'special (car language)))) (void)] @@ -468,7 +467,12 @@ (read-accept-infix-dot #f)] [(memq (cadr language) teaching-langs) (read-case-sensitive #t) - (read-decimal-as-inexact #f)])) + (read-decimal-as-inexact #f) + ;; needed to make the test-engine work + (let ([orig-ns (namespace-anchor->empty-namespace anchor)]) + (parameterize ([current-namespace orig-ns]) + (dynamic-require 'scheme/class #f)) + (namespace-attach-module orig-ns 'scheme/class))])) ;; Returns a single (module ...) or (begin ...) expression (a `begin' list ;; will be evaluated one by one -- the language might not have a `begin'). @@ -509,17 +513,16 @@ (call-with-continuation-prompt (lambda () (if (null? exprs) - (void) - (let ([deftag (default-continuation-prompt-tag)]) - (let loop ([expr (car exprs)] [exprs (cdr exprs)]) - (if (null? exprs) - (eval expr) - (begin - (call-with-continuation-prompt - (lambda () (eval expr)) - deftag - (lambda (x) (abort-current-continuation deftag x))) - (loop (car exprs) (cdr exprs)))))))))) + (void) + (let ([deftag (default-continuation-prompt-tag)]) + (let loop ([expr (car exprs)] [exprs (cdr exprs)]) + (if (null? exprs) + (eval expr) + (begin (call-with-continuation-prompt + (lambda () (eval expr)) + deftag + (lambda (x) (abort-current-continuation deftag x))) + (loop (car exprs) (cdr exprs)))))))))) ;; We need a powerful enough code inspector to invoke the errortrace library ;; (indirectly through private/sandbox-coverage). But there is a small problem @@ -532,8 +535,8 @@ (define orig-code-inspector (current-code-inspector)) (define (evaluate-program program limit-thunk uncovered!) - (parameterize ([current-code-inspector orig-code-inspector]) - (when uncovered! + (when uncovered! + (parameterize ([current-code-inspector orig-code-inspector]) (eval `(,#'#%require scheme/private/sandbox-coverage)))) (let ([ns (syntax-case* program (module) literal-identifier=? [(module mod . body) @@ -687,9 +690,11 @@ [(thunk) (limit-thunk (car (evaluator-message-args expr)))] [(thunk*) (car (evaluator-message-args expr))] [else (error 'sandbox "internal error (bad message)")]) - (limit-thunk (lambda () - (set! n (add1 n)) - (eval* (input->code (list expr) 'eval n)))))) + (limit-thunk + (lambda () + (set! n (add1 n)) + (eval* (map (lambda (expr) (cons '#%top-interaction expr)) + (input->code (list expr) 'eval n))))))) (channel-put result-ch (cons 'vals (call-with-values run list)))) (loop))))) (define (get-user-result) @@ -877,7 +882,7 @@ r `(file ,(path->string (simplify-path* r))))) requires))]) - (make-evaluator* (init-for-language lang) + (make-evaluator* (init-hook-for-language lang) (append (extract-required (or (decode-language lang) lang) reqs) allow) From e36cde06e56a0229f38866c688caf49bc72d0ec9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 25 Feb 2009 17:45:06 +0000 Subject: [PATCH 122/142] svn: r13837 --- collects/scribble/latex-render.ss | 1 + collects/scribble/private/lp.ss | 8 ++++---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index d43fcc81a9..d79d5027ac 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -417,6 +417,7 @@ [(#\u039B) "$\\Lambda$"] [(#\u03BC) "$\\mu$"] [(#\u03C0) "$\\pi$"] + [(#\∞) "$\\infty$"] [else c]))) (loop (add1 i)))))) diff --git a/collects/scribble/private/lp.ss b/collects/scribble/private/lp.ss index 092d59aa3b..3d266d4c0c 100644 --- a/collects/scribble/private/lp.ss +++ b/collects/scribble/private/lp.ss @@ -23,7 +23,7 @@ (identifier? #'name) (let ([n (get-chunk-number (syntax-local-introduce #'name) #f)] [str (symbol->string (syntax-e #'name))]) - + (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) (if (n . > . 1) @@ -43,9 +43,9 @@ #'(mod ...)] [else null])) (syntax->list #'(expr ...)))]) + (syntax-local-lift-require + #'(for-label for-label-mod ... ...) #`(begin - (require (for-label for-label-mod ... ...)) - ;; why does this happen twice? (define-syntax name (make-element-id-transformer (lambda (stx) #'(chunkref name)))) (begin-for-syntax (register-chunk-name #'name)) @@ -56,7 +56,7 @@ (bold (italic (scheme name)) " ::="))) (list (smaller (elemref '(chunk tag) #:underline? #f str)))) - (schemeblock expr ...)))))))])) + (schemeblock expr ...))))))))])) (define-syntax (chunkref stx) (syntax-case stx () From 0e3b74d12531faaf5acf43e4c133fd8b663f7bb5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 25 Feb 2009 18:18:34 +0000 Subject: [PATCH 123/142] fixed some bugs that broke the build svn: r13838 --- collects/scribble/lp/lang/lang.ss | 2 +- collects/scribble/private/lp.ss | 13 ++++++++++++- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss index b3eb79042e..180411e573 100644 --- a/collects/scribble/lp/lang/lang.ss +++ b/collects/scribble/lp/lang/lang.ss @@ -29,7 +29,7 @@ (define-syntax (tangle stx) (define chunk-mentions '()) (define stupid-internal-definition-sytnax - (unless main-id + (unless first-id (raise-syntax-error 'scribble/lp "no chunks"))) (define body (let loop ([block (if main-id diff --git a/collects/scribble/private/lp.ss b/collects/scribble/private/lp.ss index 3d266d4c0c..8e019e5d57 100644 --- a/collects/scribble/private/lp.ss +++ b/collects/scribble/private/lp.ss @@ -40,7 +40,18 @@ (map (lambda (expr) (syntax-case expr (require) [(require mod ...) - #'(mod ...)] + (let loop ([mods (syntax->list #'(mod ...))]) + (cond + [(null? mods) null] + [else + (syntax-case (car mods) (for-syntax) + [(for-syntax x ...) + (loop (cdr mods)) + #; + (append (loop (syntax->list #'(x ...))) + (loop (cdr mods)))] + [x + (cons #'x (loop (cdr mods)))])]))] [else null])) (syntax->list #'(expr ...)))]) (syntax-local-lift-require From 0321cad60e6311ed1881327ddccb94949871216c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Feb 2009 18:27:16 +0000 Subject: [PATCH 124/142] add #lang scribble/manual; change latex table rendering to use a smaller minipage for multiple columns of non-para/table cell flows svn: r13839 --- collects/scribble/latex-render.ss | 11 +++++++---- collects/scribble/manual/lang.ss | 4 ++++ collects/scribble/manual/lang/reader.ss | 10 ++++++++++ 3 files changed, 21 insertions(+), 4 deletions(-) create mode 100644 collects/scribble/manual/lang.ss create mode 100644 collects/scribble/manual/lang/reader.ss diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index d79d5027ac..e0e4798880 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -259,7 +259,10 @@ (and m (equal? "bigtabular" (car m)) (= 1 (length (car (table-flowss (cadr m))))))))] - [boxline "{\\setlength{\\unitlength}{\\linewidth}\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}"]) + [boxline "{\\setlength{\\unitlength}{\\linewidth}\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}"] + [twidth (if (null? (table-flowss t)) + 1 + (length (car (table-flowss t))))]) (unless (or (null? flowss) (null? (car flowss))) (parameterize ([current-table-mode (if inline? (current-table-mode) (list tableform t))] @@ -306,7 +309,7 @@ (loop (cdr flows) (add1 n))] [else n]))]) (unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt)) - (render-table-flow (car flows) part ri) + (render-table-flow (car flows) part ri twidth) (unless (= cnt 1) (printf "}")) (unless (null? (list-tail flows cnt)) (printf " &\n")))) (unless (null? (cdr flows)) (loop (cdr flows))))) @@ -321,7 +324,7 @@ tableform))))) null) - (define/private (render-table-flow p part ri) + (define/private (render-table-flow p part ri twidth) ;; Emit a \\ between blocks: (let loop ([ps (flow-paragraphs p)]) (cond @@ -330,7 +333,7 @@ (let ([minipage? (not (or (paragraph? (car ps)) (table? (car ps))))]) (when minipage? - (printf "\\begin{minipage}{\\linewidth}\n")) + (printf "\\begin{minipage}{~a\\linewidth}\n" (/ 1.0 twidth))) (render-block (car ps) part ri #f) (when minipage? (printf " \\end{minipage}\n")) diff --git a/collects/scribble/manual/lang.ss b/collects/scribble/manual/lang.ss new file mode 100644 index 0000000000..f3aa8bcbf4 --- /dev/null +++ b/collects/scribble/manual/lang.ss @@ -0,0 +1,4 @@ +#lang scheme +(require scribble/doclang scribble/manual) +(provide (all-from-out scribble/doclang + scribble/manual)) diff --git a/collects/scribble/manual/lang/reader.ss b/collects/scribble/manual/lang/reader.ss new file mode 100644 index 0000000000..45fc938087 --- /dev/null +++ b/collects/scribble/manual/lang/reader.ss @@ -0,0 +1,10 @@ +#lang s-exp syntax/module-reader + +scribble/manual/lang + +#:read scribble:read-inside +#:read-syntax scribble:read-syntax-inside +#:whole-body-readers? #t +#:wrapper1 (lambda (t) (list* 'doc '() (t))) + +(require (prefix-in scribble: "../../reader.ss")) From 973f08e0112c2e4027b6ee9f660955d8d472b2dd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Feb 2009 18:35:51 +0000 Subject: [PATCH 125/142] fix scribble/lp by not lifting require svn: r13840 --- collects/scribble/private/lp.ss | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/scribble/private/lp.ss b/collects/scribble/private/lp.ss index 8e019e5d57..56ff51b890 100644 --- a/collects/scribble/private/lp.ss +++ b/collects/scribble/private/lp.ss @@ -54,9 +54,8 @@ (cons #'x (loop (cdr mods)))])]))] [else null])) (syntax->list #'(expr ...)))]) - (syntax-local-lift-require - #'(for-label for-label-mod ... ...) #`(begin + (require (for-label for-label-mod ... ...)) (define-syntax name (make-element-id-transformer (lambda (stx) #'(chunkref name)))) (begin-for-syntax (register-chunk-name #'name)) @@ -67,7 +66,7 @@ (bold (italic (scheme name)) " ::="))) (list (smaller (elemref '(chunk tag) #:underline? #f str)))) - (schemeblock expr ...))))))))])) + (schemeblock expr ...)))))))])) (define-syntax (chunkref stx) (syntax-case stx () From 42adbca52765002306d46df8f660b8eb6f088a1b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 25 Feb 2009 20:35:38 +0000 Subject: [PATCH 126/142] finished fixing multiple chunks svn: r13841 --- collects/games/chat-noir/README | 6 -- collects/scribble/private/lp.ss | 107 ++++++++++++++++---------------- 2 files changed, 54 insertions(+), 59 deletions(-) diff --git a/collects/games/chat-noir/README b/collects/games/chat-noir/README index c595d62661..5fbbf86504 100644 --- a/collects/games/chat-noir/README +++ b/collects/games/chat-noir/README @@ -4,10 +4,6 @@ Games. Problems: - - handling multiple chunks is broken right now, so the - chunkref-introducting macro (in scribble/private/lp.ss) - is disabled. - - Need to make 'a-chunk' be a real macro, I expect. (used in scribble/private/lp.ss) @@ -15,8 +11,6 @@ Problems: - do unbound chunk ids signal syntax errors? How about unused ones? - - toc entries should not be underlined. - To document: @chunk diff --git a/collects/scribble/private/lp.ss b/collects/scribble/private/lp.ss index 56ff51b890..b5b189b2a3 100644 --- a/collects/scribble/private/lp.ss +++ b/collects/scribble/private/lp.ss @@ -7,73 +7,74 @@ ;; maps chunk identifiers to a counter, so we can distinguish multiple uses ;; of the same name (define chunk-numbers (make-free-identifier-mapping)) - (define (get-chunk-number id install?) - (let ([n (add1 (free-identifier-mapping-get chunk-numbers id - (lambda () 0)))]) - (when install? - (free-identifier-mapping-put! chunk-numbers id n)) - n)) - (define (register-chunk-name name) - (get-chunk-number name #t))) + (define (get-chunk-number id) + (free-identifier-mapping-get chunk-numbers id (lambda () #f))) + (define (inc-chunk-number id) + (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id)))) + (define (init-chunk-number id) + (free-identifier-mapping-put! chunk-numbers id 2))) (define-syntax (chunk stx) (syntax-case stx () [(_ name expr ...) ;; no need for more error checking, using chunk for the code will do that (identifier? #'name) - (let ([n (get-chunk-number (syntax-local-introduce #'name) #f)] - [str (symbol->string (syntax-e #'name))]) + (let* ([n (get-chunk-number (syntax-local-introduce #'name))] + [str (symbol->string (syntax-e #'name))] + [tag (format "~a:~a" str (or n 1))]) + + (when n + (inc-chunk-number (syntax-local-introduce #'name))) (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) - (if (n . > . 1) - (let ([str - (format - "need to handle secondary tags: ~a ~a\n" - n - str)]) - #`(begin - (italic #,str))) - (with-syntax ([tag str] - [str str] - [((for-label-mod ...) ...) - (map (lambda (expr) - (syntax-case expr (require) - [(require mod ...) - (let loop ([mods (syntax->list #'(mod ...))]) - (cond - [(null? mods) null] - [else - (syntax-case (car mods) (for-syntax) - [(for-syntax x ...) - (loop (cdr mods)) - #; - (append (loop (syntax->list #'(x ...))) - (loop (cdr mods)))] - [x - (cons #'x (loop (cdr mods)))])]))] - [else null])) - (syntax->list #'(expr ...)))]) - #`(begin - (require (for-label for-label-mod ... ...)) - (define-syntax name (make-element-id-transformer - (lambda (stx) #'(chunkref name)))) - (begin-for-syntax (register-chunk-name #'name)) - (make-splice - (list (make-toc-element - #f - (list (elemtag '(chunk tag) - (bold (italic (scheme name)) " ::="))) - (list (smaller (elemref '(chunk tag) #:underline? #f - str)))) - (schemeblock expr ...)))))))])) + (with-syntax ([tag tag] + [str str] + [((for-label-mod ...) ...) + (map (lambda (expr) + (syntax-case expr (require) + [(require mod ...) + (let loop ([mods (syntax->list #'(mod ...))]) + (cond + [(null? mods) null] + [else + (syntax-case (car mods) (for-syntax) + [(for-syntax x ...) + (append (loop (syntax->list #'(x ...))) + (loop (cdr mods)))] + [x + (cons #'x (loop (cdr mods)))])]))] + [else null])) + (syntax->list #'(expr ...)))] + + [(rest ...) (if n + #`((subscript #,(format "~a" n))) + #`())]) + + #`(begin + (require (for-label for-label-mod ... ...)) + #,@(if n + #'() + #'((define-syntax name (make-element-id-transformer + (lambda (stx) #'(chunkref name)))) + (begin-for-syntax (init-chunk-number #'name)))) + (make-splice + (list (make-toc-element + #f + (list (elemtag '(chunk tag) + (bold (italic (scheme name)) " ::="))) + (list (smaller (elemref '(chunk tag) #:underline? #f + str + rest ...)))) + (schemeblock expr ...))))))])) (define-syntax (chunkref stx) (syntax-case stx () [(_ id) (identifier? #'id) - (with-syntax ([str (format "~a" (syntax-e #'id))]) - #'(elemref '(chunk str) #:underline? #f str))])) + (with-syntax ([tag (format "~a:1" (syntax-e #'id))] + [str (format "~a" (syntax-e #'id))]) + #'(elemref '(chunk tag) #:underline? #f str))])) (provide (all-from-out scheme/base From 79b906e713ad80ccede4be7da7fcb609c3ff4412 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Feb 2009 21:12:18 +0000 Subject: [PATCH 127/142] fix MrEd mac event-loop problems svn: r13842 --- src/mred/mredmac.cxx | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/src/mred/mredmac.cxx b/src/mred/mredmac.cxx index aea2890f82..d585074b68 100644 --- a/src/mred/mredmac.cxx +++ b/src/mred/mredmac.cxx @@ -285,9 +285,6 @@ static int waiting_for_next_event; static int wne_handlersInstalled; static int pending_self_ae; -static int ae_target_ready = 0; -static AEAddressDesc ae_target; - static void EnsureWNEReturn() { /* Generate an event that WaitNextEvent() will return, but that we can @@ -301,18 +298,17 @@ static void EnsureWNEReturn() dummy AppleEvent and defeat the purpose. */ if (!pending_self_ae) { ProcessSerialNumber psn; - AppleEvent ae; + AppleEvent ae, ae_target; pending_self_ae = 1; GetCurrentProcess(&psn); - if (!ae_target_ready) { - AECreateDesc(typeProcessSerialNumber, &psn, sizeof(psn), &ae_target); - ae_target_ready = 1; - } + AECreateDesc(typeProcessSerialNumber, &psn, sizeof(psn), &ae_target); AECreateAppleEvent('MrEd', 'Smug', &ae_target, kAutoGenerateReturnID, kAnyTransactionID, &ae); AESend(&ae, NULL, kAENoReply, kAENormalPriority, kNoTimeOut, NULL, NULL); - AEDisposeDesc(&ae); + /* Not supposed to dispose? */ + /* AEDisposeDesc(&ae); */ + /* AEDisposeDesc(&ae_target); */ } } From 90bc1d816d4645f7f7a3be99cf2e05c9bdfbef8d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Feb 2009 21:14:22 +0000 Subject: [PATCH 128/142] fix some Scribble rendering issues with tables containing flows abd cell styles; extend Slideshow play to handle more optional arguments; fix some docs svn: r13843 --- collects/scribble/html-render.ss | 21 ++++--- collects/scribble/latex-render.ss | 62 +++++++++++++------ .../scribblings/reference/stx-trans.scrbl | 9 +-- collects/scribblings/scribble/struct.scrbl | 17 ++--- collects/slideshow/play.ss | 11 ++-- 5 files changed, 76 insertions(+), 44 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 3349b37adf..2f1bf1556f 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -1044,22 +1044,24 @@ (with-attributes-style raw-style) raw-style)) (define t-style-get (if (and (pair? t-style) (list? t-style)) - (lambda (k) (assoc k t-style)) - (lambda (k) #f))) + (lambda (k) (assoc k t-style)) + (lambda (k) #f))) (define (make-row flows style) - `(tr (,@(if style `([class ,style]) null)) + `(tr (,@(if (string? style) `([class ,style]) null)) ,@(let loop ([ds flows] - [as (cdr (or (t-style-get 'alignment) + [as (cdr (or (and (list? style) (assq 'alignment style)) (cons #f (map (lambda (x) #f) flows))))] - [vas (cdr (or (t-style-get 'valignment) + [vas (cdr (or (and (list? style) (assq 'valignment style)) + (cons #f (map (lambda (x) #f) flows))))] + [sts (cdr (or (and (list? style) (assq 'style style)) (cons #f (map (lambda (x) #f) flows))))] [first? #t]) (cond [(null? ds) null] [(eq? (car ds) 'cont) - (loop (cdr ds) (cdr as) (cdr vas) first?)] + (loop (cdr ds) (cdr as) (cdr vas) (cdr sts) first?)] [else - (let ([d (car ds)] [a (car as)] [va (car vas)]) + (let ([d (car ds)] [a (car as)] [va (car vas)] [st (car sts)]) (cons `(td (,@(case a [(#f) null] @@ -1071,6 +1073,9 @@ [(top) '((valign "top"))] [(baseline) '((valign "baseline"))] [(bottom) '((valign "bottom"))]) + ,@(if (string? st) + `([class ,st]) + null) ,@(if (and (pair? (cdr ds)) (eq? 'cont (cadr ds))) `([colspan @@ -1085,7 +1090,7 @@ (omitable-paragraph? (car (flow-paragraphs d)))) (render-content (paragraph-content (car (flow-paragraphs d))) part ri) (render-flow d part ri #f))) - (loop (cdr ds) (cdr as) (cdr vas) #f)))])))) + (loop (cdr ds) (cdr as) (cdr vas) (cdr sts) #f)))])))) `((table ([cellspacing "0"] ,@(if need-inline? '([style "display: inline-table; vertical-align: text-top;"]) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index e0e4798880..19ff53071b 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -299,7 +299,10 @@ [row-styles row-styles]) (let ([flows (car flowss)] [row-style (car row-styles)]) - (let loop ([flows flows]) + (let loop ([flows flows] + [col-v-styles (and (list? row-style) + (let ([p (assoc 'valignment row-style)]) + (and p (cdr p))))]) (unless (null? flows) (when index? (printf "\\item ")) (unless (eq? 'cont (car flows)) @@ -309,10 +312,12 @@ (loop (cdr flows) (add1 n))] [else n]))]) (unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt)) - (render-table-flow (car flows) part ri twidth) + (render-table-flow (car flows) part ri twidth (and col-v-styles + (car col-v-styles))) (unless (= cnt 1) (printf "}")) (unless (null? (list-tail flows cnt)) (printf " &\n")))) - (unless (null? (cdr flows)) (loop (cdr flows))))) + (unless (null? (cdr flows)) (loop (cdr flows) + (and col-v-styles (cdr col-v-styles)))))) (unless (or index? (null? (cdr flowss))) (printf " \\\\\n") (when (equal? row-style "inferencetop") (printf "\\hline\n"))) @@ -324,23 +329,40 @@ tableform))))) null) - (define/private (render-table-flow p part ri twidth) - ;; Emit a \\ between blocks: - (let loop ([ps (flow-paragraphs p)]) - (cond - [(null? ps) (void)] - [else - (let ([minipage? (not (or (paragraph? (car ps)) - (table? (car ps))))]) - (when minipage? - (printf "\\begin{minipage}{~a\\linewidth}\n" (/ 1.0 twidth))) - (render-block (car ps) part ri #f) - (when minipage? - (printf " \\end{minipage}\n")) - (unless (null? (cdr ps)) - (printf " \\\\\n") - (loop (cdr ps))))])) - null) + (define/private (render-table-flow p part ri twidth vstyle) + ;; Emit a \\ between blocks in single-column mode, + ;; used a nested table otherwise for multiple elements. + (let ([in-table? (or (and (not (= twidth 1)) + ((length (flow-paragraphs p)) . > . 1)) + (eq? vstyle 'top))]) + (when in-table? + (printf "\\begin{tabular}~a{@{}l@{}}\n" + (cond + [(eq? vstyle 'top) "[t]"] + [else ""]))) + (let loop ([ps (flow-paragraphs p)]) + (cond + [(null? ps) (void)] + [else + (let ([minipage? (not (or (paragraph? (car ps)) + (table? (car ps))))]) + (when minipage? + (printf "\\begin{minipage}~a{~a\\linewidth}\n" + (cond + [(eq? vstyle 'top) "[t]"] + [else ""]) + (/ 1.0 twidth))) + (render-block (car ps) part ri #f) + (when minipage? + (printf " \\end{minipage}\n")) + (unless (null? (cdr ps)) + (printf " \\\\\n") + (when in-table? + (printf " ~ \\\\\n")) + (loop (cdr ps))))])) + (when in-table? + (printf "\n\\end{tabular}\n")) + null)) (define/override (render-itemization t part ri) (printf "\n\n\\begin{itemize}\n") diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 2e12e90b4c..50e2613777 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -352,13 +352,14 @@ eventually expanded in an expression context. @transform-time[]} -@defproc[(syntax-local-lift-require [quoted-raw-require-spec any/c][stx syntax?]) +@defproc[(syntax-local-lift-require [raw-require-spec any/c][stx syntax?]) syntax?]{ Lifts a @scheme[#%require] form corresponding to -@scheme[quoted-raw-require-spec] to the top-level or to the top of the -module currently being expanded, wrapping it with @scheme[for-meta] if -the current expansion context is not @tech{phase level} 0. +@scheme[raw-require-spec] (either as a @tech{syntax object} or datum) +to the top-level or to the top of the module currently being expanded, +wrapping it with @scheme[for-meta] if the current expansion context is +not @tech{phase level} 0. The resulting syntax object is the same as @scheme[stx], except that a fresh @tech{syntax mark} is added. The same @tech{syntax mark} is diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index abdbfbd61d..f0912ac1d6 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -418,13 +418,16 @@ The @scheme[style] can be any of the following: @item{@scheme['row-styles] to a list of association lists, one for each row in the table. Each of these nested - association lists maps @scheme['alignment] and - @scheme['valignment] to a list of symbols an - @scheme[#f]s, one for each column. The symbols in an - @scheme['alignment] list can be @scheme['left], - @scheme['right], or @scheme['center]. The symbols in a - @scheme['valignment] list can be @scheme['top], - @scheme['baseline], or @scheme['bottom].} + association lists can map @scheme['alignment] and + @scheme['valignment] to a list of symbols and + @scheme[#f]s (one for each column cell) and/or + @scheme['style] to a list of strings and @scheme[#f]s + (one for each column cell) for a CSS class in HTML + output. The symbols in an @scheme['alignment] list can + be @scheme['left], @scheme['right], or + @scheme['center]. The symbols in a @scheme['valignment] + list can be @scheme['top], @scheme['baseline], or + @scheme['bottom].} ]} diff --git a/collects/slideshow/play.ss b/collects/slideshow/play.ss index caa81f8c0f..873cdc8888 100644 --- a/collects/slideshow/play.ss +++ b/collects/slideshow/play.ss @@ -18,12 +18,12 @@ ;; Create a slide sequence where `mid' takes a number from 0.0 to 1.0. ;; The 0.0 slide will wit until you advance, but the remaining ones will ;; time out automatically to create the animation. -(define (play #:title [title #f] mid) - (slide #:title title (mid 0)) +(define (play #:title [title #f] #:layout [layout 'auto] mid) + (slide #:title title #:layout layout (mid 0)) (if condense? (skip-slides 10) (map (lambda (n) - (slide #:title title #:timeout 0.05 (mid n))) + (slide #:title title #:layout layout #:timeout 0.05 (mid n))) (let ([cnt 10]) (let loop ([n cnt]) (if (zero? n) @@ -36,14 +36,15 @@ ;; arguments will be 0.0. The first argument goes from 0.0 to 1.0 ;; for the first `play' sequence, and then it stays at 1.0 while ;; the second goes from 0.0 to 1.0 for the second sequence, etc. -(define (play-n #:title [title #f] mid) +(define (play-n #:title [title #f] #:layout [layout 'auto] mid) (let ([n (procedure-arity mid)]) (let loop ([post (vector->list (make-vector n))] [pre null]) (if (null? post) - (slide #:title title (apply mid pre)) + (slide #:title title #:layout layout (apply mid pre)) (begin (play #:title title + #:layout layout (lambda (n) (apply mid (append pre (list n) (cdr post))))) (loop (cdr post) (cons 1.0 pre))))))) From 75158d07cb707b53d524619f6b42b1a2a7907582 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 26 Feb 2009 02:07:53 +0000 Subject: [PATCH 129/142] a little more progress svn: r13844 --- collects/games/chat-noir/README | 3 + .../games/chat-noir/chat-noir-literate.ss | 505 ++++++++++-------- 2 files changed, 288 insertions(+), 220 deletions(-) diff --git a/collects/games/chat-noir/README b/collects/games/chat-noir/README index 5fbbf86504..4d401ef9d8 100644 --- a/collects/games/chat-noir/README +++ b/collects/games/chat-noir/README @@ -4,6 +4,9 @@ Games. Problems: + - Run in the module language doesn't seem to work anymore, in that + definitions in the literate program don't show up in the REPL. + - Need to make 'a-chunk' be a real macro, I expect. (used in scribble/private/lp.ss) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 5a951e0ff6..532b893805 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1086,7 +1086,11 @@ the screen resolution. @section{Handling Input} +Input handling consists of handling two different kinds of events: key events, and mouse events, +plus various helper functions. + @chunk[ + @@ -1096,8 +1100,7 @@ the screen resolution. - - ] + ] @chunk[ @@ -1109,8 +1112,21 @@ the screen resolution. ] +The @scheme[change] function handles keyboard input and merely updates the @tt{h-down?} field +based on the state of the key event. + +@chunk[ + ;; change : world key-event -> world + (define (change w ke) + (make-world (world-board w) + (world-cat w) + (world-state w) + (world-size w) + (world-mouse-posn w) + (key=? ke #\h)))] + The @scheme[clack] function handles mouse input. It has three tasks and each corresponds -to a specific helper function: +to a helper function: @itemize{ @item{block the clicked cell (@scheme[block-cell/world]),} @item{move the cat (@scheme[move-cat]), and} @@ -1140,7 +1156,9 @@ player's move (via the @scheme[player-moved?] function. The @scheme[player-moved?] predicate returns a @scheme[posn] indicating where the player chose to move when the mouse event corresponds to a player move, -and returns @scheme[#f]. +and returns @scheme[#f]. It first checks to see if the +mouse event is a button up event and that the game +is not over, and then it just calls @scheme[circle-at-point]. @chunk[ (define/contract (player-moved? world x y evt) @@ -1150,6 +1168,71 @@ and returns @scheme[#f]. (equal? 'playing (world-state world)) (circle-at-point (world-board world) x y)))] +The @scheme[circle-at-point] function returns a @scheme[posn] when +the coordinate (@scheme[x],@scheme[y]) is inside a circle +on the given board. Instead of computing the nearest +circle to the coordinates, it simply iterates over the cells on the +board and returns the @scheme[posn] of the matching cell. + +@chunk[ + (define/contract (circle-at-point board x y) + (-> (listof cell?) real? real? + (or/c posn? #f)) + (ormap (λ (cell) + (and (point-in-this-circle? (cell-p cell) x y) + (cell-p cell))) + board))] + + +The @scheme[point-in-this-circle?] function returns @scheme[#t] +when the point (@scheme[x],@scheme[y]) on the screen +falls within the circle located at the @scheme[posn] @scheme[p]. + +This is precise about checking the circles. For example, +a point that is (14,14) away from the center of a circle +is still in the circle: + +@chunk[ + (test (point-in-this-circle? + (make-posn 1 0) + (+ (cell-center-x (make-posn 1 0)) 14) + (+ (cell-center-y (make-posn 1 0)) 14)) + #t)] + +but one that is (15,15) away is no longer in the circle, +since it crosses the boundary away from a circle of radius +20 at that point. + +@chunk[ + (test (point-in-this-circle? + (make-posn 1 0) + (+ (cell-center-x (make-posn 1 0)) 15) + (+ (cell-center-y (make-posn 1 0)) 15)) + #f)] + +The implementation of @scheme[point-in-this-circle?] uses +complex numbers to represent both points on the screen +and directional vectors. In particular, the +variable @scheme[center] is a complex number whose +real part is the @tt{x} coordinate of the center of +the cell at @scheme[p], and its imaginary part is +@tt{y} coordinate. Similarly, @scheme[mp] is bound +to a complex number corresponding to the position of +the mouse, at (@scheme[x], @scheme[y]). Then, the +function computes the vector between the two points +by subtracting the complex numbers from each +other and extracting the magnitude from that vector. + +@chunk[ + (define/contract (point-in-this-circle? p x y) + (-> posn? real? real? boolean?) + (let ([center (+ (cell-center-x p) + (* (sqrt -1) + (cell-center-y p)))] + [mp (+ x (* (sqrt -1) y))]) + (<= (magnitude (- center mp)) + circle-radius)))] + In the event that @scheme[player-moved?] returns a @scheme[posn], the @scheme[clack] function blocks the clicked on cell using @scheme[block-cell/world], which simply calls @scheme[block-cell]. @@ -1222,8 +1305,43 @@ position and whether or not the cat won. (world-mouse-posn world) (world-h-down? world))] + +@chunk[ + ;; find-best-positions : (nelistof posn) (nelistof number or '∞) + ;; -> (nelistof posn) or #f + (define (find-best-positions posns scores) + (local [(define best-score (foldl (lambda (x sofar) + (if (<=/f x sofar) + x + sofar)) + (first scores) + (rest scores)))] + (cond + [(symbol? best-score) #f] + [else + (map + second + (filter (lambda (x) (equal? (first x) best-score)) + (map list scores posns)))])))] + + + +@chunk[ + ;; <=/f : (number or '∞) (number or '∞) -> boolean + (define (<=/f a b) + (cond + [(equal? b '∞) #t] + [(equal? a '∞) #f] + [else (<= a b)]))] + + Finally, to complete the mouse event handling, the @scheme[update-world-posn] -function is called from @scheme[clack]. It updates +function is called from @scheme[clack]. It updates the @tt{mouse-down} +field of the @scheme[world]. If the @scheme[p] argument is a @scheme[posn], +it corresponds to the location of the mouse, in graphical coordinates. +So, the function converts it to a cell position on the board and uses that. +Otherwise, when @scheme[p] is @scheme[#f], the @tt{mouse-down} field +is just updated to @scheme[#f]. @chunk[ (define/contract (update-world-posn w p) @@ -1253,219 +1371,6 @@ function is called from @scheme[clack]. It updates #f (world-h-down? w))]))] -@chunk[ - - (test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) #f)) - (make-posn 0 1) 'playing 3 #f #f) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) #f)) - (make-posn 0 1) 'playing 3 (make-posn 0 0) #f)) - - (test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) #f)) - (make-posn 0 0) 'playing 3 #f #f) - (make-posn (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) #f)) - (make-posn 0 0) 'playing 3 #f #f)) - - (test (update-world-posn - (make-world (list (make-cell (make-posn 0 0) #f)) - (make-posn 0 1) 'playing 3 (make-posn 0 0) #f) - (make-posn 0 0)) - (make-world (list (make-cell (make-posn 0 0) #f)) - (make-posn 0 1) 'playing 3 #f #f))] - -@chunk[ - (test - (move-cat - (make-world (list (make-cell (make-posn 1 0) #f) - (make-cell (make-posn 2 0) #f) - (make-cell (make-posn 3 0) #f) - (make-cell (make-posn 4 0) #f) - - (make-cell (make-posn 0 1) #f) - (make-cell (make-posn 1 1) #t) - (make-cell (make-posn 2 1) #t) - (make-cell (make-posn 3 1) #f) - (make-cell (make-posn 4 1) #f) - - (make-cell (make-posn 0 2) #f) - (make-cell (make-posn 1 2) #t) - (make-cell (make-posn 2 2) #f) - (make-cell (make-posn 3 2) #t) - (make-cell (make-posn 4 2) #f) - - (make-cell (make-posn 0 3) #f) - (make-cell (make-posn 1 3) #t) - (make-cell (make-posn 2 3) #f) - (make-cell (make-posn 3 3) #f) - (make-cell (make-posn 4 3) #f) - - (make-cell (make-posn 1 4) #f) - (make-cell (make-posn 2 4) #f) - (make-cell (make-posn 3 4) #f) - (make-cell (make-posn 4 4) #f)) - (make-posn 2 2) - 'playing - 5 - (make-posn 0 0) - #f)) - (make-world (list (make-cell (make-posn 1 0) #f) - (make-cell (make-posn 2 0) #f) - (make-cell (make-posn 3 0) #f) - (make-cell (make-posn 4 0) #f) - - (make-cell (make-posn 0 1) #f) - (make-cell (make-posn 1 1) #t) - (make-cell (make-posn 2 1) #t) - (make-cell (make-posn 3 1) #f) - (make-cell (make-posn 4 1) #f) - - (make-cell (make-posn 0 2) #f) - (make-cell (make-posn 1 2) #t) - (make-cell (make-posn 2 2) #f) - (make-cell (make-posn 3 2) #t) - (make-cell (make-posn 4 2) #f) - - (make-cell (make-posn 0 3) #f) - (make-cell (make-posn 1 3) #t) - (make-cell (make-posn 2 3) #f) - (make-cell (make-posn 3 3) #f) - (make-cell (make-posn 4 3) #f) - - (make-cell (make-posn 1 4) #f) - (make-cell (make-posn 2 4) #f) - (make-cell (make-posn 3 4) #f) - (make-cell (make-posn 4 4) #f)) - (make-posn 2 3) - 'playing - 5 - (make-posn 0 0) - #f))] - -@chunk[ - ;; find-best-positions : (nelistof posn) (nelistof number or '∞) - ;; -> (nelistof posn) or #f - (define (find-best-positions posns scores) - (local [(define best-score (foldl (lambda (x sofar) - (if (<=/f x sofar) - x - sofar)) - (first scores) - (rest scores)))] - (cond - [(symbol? best-score) #f] - [else - (map - second - (filter (lambda (x) (equal? (first x) best-score)) - (map list scores posns)))])))] - -@chunk[ - (test (find-best-positions (list (make-posn 0 0)) (list 1)) - (list (make-posn 0 0))) - (test (find-best-positions (list (make-posn 0 0)) (list '∞)) - #f) - (test (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list 1 2)) - (list (make-posn 0 0))) - (test (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list 1 1)) - (list (make-posn 0 0) - (make-posn 1 1))) - (test (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list '∞ 2)) - (list (make-posn 1 1))) - (test (find-best-positions (list (make-posn 0 0) - (make-posn 1 1)) - (list '∞ '∞)) - #f)] - -@chunk[ - ;; <=/f : (number or '∞) (number or '∞) -> boolean - (define (<=/f a b) - (cond - [(equal? b '∞) #t] - [(equal? a '∞) #f] - [else (<= a b)]))] - -@chunk[ - (test (<=/f 1 2) #t) - (test (<=/f 2 1) #f) - (test (<=/f '∞ 1) #f) - (test (<=/f 1 '∞) #t) - (test (<=/f '∞ '∞) #t)] - -@chunk[ - ;; circle-at-point : board number number -> posn-or-#f - ;; returns the posn corresponding to cell where the x,y coordinates are - (define (circle-at-point board x y) - (cond - [(empty? board) #f] - [else - (cond - [(point-in-this-circle? (cell-p (first board)) x y) - (cell-p (first board))] - [else - (circle-at-point (rest board) x y)])]))] - -@chunk[ - (test (circle-at-point empty 0 0) #f) - (test (circle-at-point (list (make-cell (make-posn 0 0) #f)) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - (make-posn 0 0)) - (test (circle-at-point (list (make-cell (make-posn 0 0) #f)) - 0 0) - #f)] - -@chunk[ - ;; point-in-this-circle? : posn number number -> boolean - (define (point-in-this-circle? p x y) - (let ([center (+ (cell-center-x p) - (* (sqrt -1) - (cell-center-y p)))] - [p2 (+ x (* (sqrt -1) y))]) - (<= (magnitude (- center p2)) - circle-radius)))] - -@chunk[ - (test (point-in-this-circle? (make-posn 0 0) - (cell-center-x (make-posn 0 0)) - (cell-center-y (make-posn 0 0))) - #t) - (test (point-in-this-circle? (make-posn 0 0) 0 0) - #f)] - -@chunk[ - ;; change : world key-event -> world - (define (change w ke) - (make-world (world-board w) - (world-cat w) - (world-state w) - (world-size w) - (world-mouse-posn w) - (key=? ke #\h)))] - -@chunk[ - (test (change (make-world '() (make-posn 1 1) - 'playing 3 (make-posn 0 0) #f) - #\h) - (make-world '() (make-posn 1 1) - 'playing 3 (make-posn 0 0) #t)) - (test (change (make-world '() (make-posn 1 1) - 'playing 3 (make-posn 0 0) #t) - 'release) - (make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) #f))] - - -] @section{Tests} @@ -2230,11 +2135,171 @@ for the other functions in this document #f #f))] +@chunk[ + + (test (update-world-posn + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) 'playing 3 #f #f) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) 'playing 3 (make-posn 0 0) #f)) + + (test (update-world-posn + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 0) 'playing 3 #f #f) + (make-posn (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0)))) + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 0) 'playing 3 #f #f)) + + (test (update-world-posn + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) 'playing 3 (make-posn 0 0) #f) + (make-posn 0 0)) + (make-world (list (make-cell (make-posn 0 0) #f)) + (make-posn 0 1) 'playing 3 #f #f))] + +@chunk[ + (test + (move-cat + (make-world (list (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 3 0) #f) + (make-cell (make-posn 4 0) #f) + + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 1) #t) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 3 1) #f) + (make-cell (make-posn 4 1) #f) + + (make-cell (make-posn 0 2) #f) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 2) #f) + (make-cell (make-posn 3 2) #t) + (make-cell (make-posn 4 2) #f) + + (make-cell (make-posn 0 3) #f) + (make-cell (make-posn 1 3) #t) + (make-cell (make-posn 2 3) #f) + (make-cell (make-posn 3 3) #f) + (make-cell (make-posn 4 3) #f) + + (make-cell (make-posn 1 4) #f) + (make-cell (make-posn 2 4) #f) + (make-cell (make-posn 3 4) #f) + (make-cell (make-posn 4 4) #f)) + (make-posn 2 2) + 'playing + 5 + (make-posn 0 0) + #f)) + (make-world (list (make-cell (make-posn 1 0) #f) + (make-cell (make-posn 2 0) #f) + (make-cell (make-posn 3 0) #f) + (make-cell (make-posn 4 0) #f) + + (make-cell (make-posn 0 1) #f) + (make-cell (make-posn 1 1) #t) + (make-cell (make-posn 2 1) #t) + (make-cell (make-posn 3 1) #f) + (make-cell (make-posn 4 1) #f) + + (make-cell (make-posn 0 2) #f) + (make-cell (make-posn 1 2) #t) + (make-cell (make-posn 2 2) #f) + (make-cell (make-posn 3 2) #t) + (make-cell (make-posn 4 2) #f) + + (make-cell (make-posn 0 3) #f) + (make-cell (make-posn 1 3) #t) + (make-cell (make-posn 2 3) #f) + (make-cell (make-posn 3 3) #f) + (make-cell (make-posn 4 3) #f) + + (make-cell (make-posn 1 4) #f) + (make-cell (make-posn 2 4) #f) + (make-cell (make-posn 3 4) #f) + (make-cell (make-posn 4 4) #f)) + (make-posn 2 3) + 'playing + 5 + (make-posn 0 0) + #f))] + +@chunk[ + (test (change (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) #f) + #\h) + (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) #t)) + (test (change (make-world '() (make-posn 1 1) + 'playing 3 (make-posn 0 0) #t) + 'release) + (make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) #f))] + + + + +@chunk[ + (test (point-in-this-circle? (make-posn 0 0) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + #t) + (test (point-in-this-circle? (make-posn 0 0) 0 0) + #f)] + +@chunk[ + (test (find-best-positions (list (make-posn 0 0)) (list 1)) + (list (make-posn 0 0))) + (test (find-best-positions (list (make-posn 0 0)) (list '∞)) + #f) + (test (find-best-positions (list (make-posn 0 0) + (make-posn 1 1)) + (list 1 2)) + (list (make-posn 0 0))) + (test (find-best-positions (list (make-posn 0 0) + (make-posn 1 1)) + (list 1 1)) + (list (make-posn 0 0) + (make-posn 1 1))) + (test (find-best-positions (list (make-posn 0 0) + (make-posn 1 1)) + (list '∞ 2)) + (list (make-posn 1 1))) + (test (find-best-positions (list (make-posn 0 0) + (make-posn 1 1)) + (list '∞ '∞)) + #f)] + +@chunk[ + (test (<=/f 1 2) #t) + (test (<=/f 2 1) #f) + (test (<=/f '∞ 1) #f) + (test (<=/f 1 '∞) #t) + (test (<=/f '∞ '∞) #t)] + +@chunk[ + (test (circle-at-point empty 0 0) #f) + (test (circle-at-point (list (make-cell (make-posn 0 0) #f)) + (cell-center-x (make-posn 0 0)) + (cell-center-y (make-posn 0 0))) + (make-posn 0 0)) + (test (circle-at-point (list (make-cell (make-posn 0 0) #f) + (make-cell (make-posn 0 1) #f)) + (cell-center-x (make-posn 0 1)) + (cell-center-y (make-posn 0 1))) + (make-posn 0 1)) + (test (circle-at-point (list (make-cell (make-posn 0 0) #f)) + 0 0) + #f)] + + @section{Run, program, run} @chunk[ - ;(printf "passed ~s tests\n" test-count) - ;(flush-output) + (printf "passed ~s tests\n" test-count) (flush-output) (let* ([board-size 11] [initial-board From 8c4e8236a84efd287e3bd3a810548707fe21b613 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 26 Feb 2009 08:50:17 +0000 Subject: [PATCH 130/142] Welcome to a new PLT day. svn: r13845 --- 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 22f815ec9b..0e5b68f305 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "25feb2009") +#lang scheme/base (provide stamp) (define stamp "26feb2009") From 50dff6234c82deb41e470150ecdb12ec0ed6c74f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Feb 2009 13:11:11 +0000 Subject: [PATCH 131/142] add syntax/strip-context svn: r13846 --- collects/syntax/strip-context.ss | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 collects/syntax/strip-context.ss diff --git a/collects/syntax/strip-context.ss b/collects/syntax/strip-context.ss new file mode 100644 index 0000000000..7e0be69eed --- /dev/null +++ b/collects/syntax/strip-context.ss @@ -0,0 +1,20 @@ +#lang scheme/base + +(define (strip-context e) + (cond + [(syntax? e) + (datum->syntax #f + (strip-context (syntax-e e)) + e + e)] + [(pair? e) (cons (strip-context (car e)) + (strip-context (cdr e)))] + [(vector? e) (list->vector + (map strip-context + (vector->list e)))] + [(box? e) (box (strip-context (unbox e)))] + [(prefab-struct-key e) + => (lambda (k) + (apply make-prefab-struct + (strip-context (cdr (vector->list (struct->vector e))))))] + [else e])) From f0473137e6a34858f3cc2861fedc7f9ee55d6949 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Feb 2009 13:19:25 +0000 Subject: [PATCH 132/142] fix and document syntax/strip-context svn: r13847 --- collects/scheme/load.ss | 22 +------------------ collects/slideshow/core.ss | 17 ++++++++++---- .../syntax/scribblings/strip-context.scrbl | 12 ++++++++++ .../scribblings/syntax-object-helpers.scrbl | 1 + collects/syntax/strip-context.ss | 2 ++ 5 files changed, 29 insertions(+), 25 deletions(-) create mode 100644 collects/syntax/scribblings/strip-context.scrbl diff --git a/collects/scheme/load.ss b/collects/scheme/load.ss index 8794f28170..eb64965370 100644 --- a/collects/scheme/load.ss +++ b/collects/scheme/load.ss @@ -1,4 +1,5 @@ #lang scheme +(require syntax/strip-context) (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction])) @@ -40,24 +41,3 @@ (lambda () (set! namespace (current-namespace)) (current-namespace ns))))) - -(define (strip-context e) - (cond - [(syntax? e) - (datum->syntax #f - (strip-context (syntax-e e)) - e - e)] - [(pair? e) (cons (strip-context (car e)) - (strip-context (cdr e)))] - [(vector? e) (list->vector - (map strip-context - (vector->list e)))] - [(box? e) (box (strip-context (unbox e)))] - [(prefab-struct-key e) - => (lambda (k) - (apply make-prefab-struct - (strip-context (cdr (vector->list (struct->vector e))))))] - [else e])) - - diff --git a/collects/slideshow/core.ss b/collects/slideshow/core.ss index 614b20ddcb..dd8e7bc755 100644 --- a/collects/slideshow/core.ss +++ b/collects/slideshow/core.ss @@ -561,6 +561,11 @@ (define ah (arrowhead gap-size 0)) (define current-item (colorize (hc-append (- (/ gap-size 2)) ah ah) blue)) (define other-item (rc-superimpose (ghost current-item) (colorize ah "light gray"))) + (define (to-next l) + (let ([l (cdddr l)]) + (if (and (pair? l) (number? (car l))) + (cdr l) + l))) (lambda (which) (slide/name (format "--~a--" @@ -569,7 +574,7 @@ [(null? l) ""] [(eq? (car l) which) (cadr l)] - [else (loop (cdddr l))]))) + [else (loop (to-next l))]))) (blank (+ title-h gap-size)) (lc-superimpose (blank (current-para-width) 0) @@ -581,7 +586,7 @@ (and (list? (car l)) (memq which (car l))))]) (vc-append - gap-size + gap-size (page-para (hbl-append (quotient gap-size 2) @@ -592,8 +597,12 @@ (if (pict? p) p (bt p))))) - (let ([rest (loop (cdddr l))] - [sub-items (caddr l)]) + (let* ([rest (let ([p (loop (to-next l))] + [l (cdddr l)]) + (if (and (pair? l) (number? (car l))) + (inset p 0 (car l) 0 0) + p))] + [sub-items (caddr l)]) (if (and current? sub-items (not (null? sub-items))) diff --git a/collects/syntax/scribblings/strip-context.scrbl b/collects/syntax/scribblings/strip-context.scrbl new file mode 100644 index 0000000000..0953ef514c --- /dev/null +++ b/collects/syntax/scribblings/strip-context.scrbl @@ -0,0 +1,12 @@ +#lang scribble/doc +@(require "common.ss" + (for-label syntax/strip-context)) + +@title[#:tag "strip-context"]{Stripping Lexical Context} + +@defmodule[syntax/strip-context] + +@defproc[(strip-context [stx syntax?]) syntax?]{ + +Removes all lexical context from @scheme[stx], preserving +source-location information and properties.} diff --git a/collects/syntax/scribblings/syntax-object-helpers.scrbl b/collects/syntax/scribblings/syntax-object-helpers.scrbl index ea9c505da2..bff81ea78d 100644 --- a/collects/syntax/scribblings/syntax-object-helpers.scrbl +++ b/collects/syntax/scribblings/syntax-object-helpers.scrbl @@ -8,5 +8,6 @@ @include-section["boundmap.scrbl"] @include-section["to-string.scrbl"] @include-section["free-vars.scrbl"] +@include-section["strip-context.scrbl"] @include-section["zodiac.scrbl"] diff --git a/collects/syntax/strip-context.ss b/collects/syntax/strip-context.ss index 7e0be69eed..81a3bafc6e 100644 --- a/collects/syntax/strip-context.ss +++ b/collects/syntax/strip-context.ss @@ -1,5 +1,7 @@ #lang scheme/base +(provide strip-context) + (define (strip-context e) (cond [(syntax? e) From 9df218784ad23abb98be72d2eef03d03ef2fa899 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Feb 2009 13:40:59 +0000 Subject: [PATCH 133/142] fix srcloc and binding tracking in scribble/lp svn: r13849 --- collects/scribble/lp/lang/lang.ss | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss index 180411e573..05421233aa 100644 --- a/collects/scribble/lp/lang/lang.ss +++ b/collects/scribble/lp/lang/lang.ss @@ -3,7 +3,8 @@ (provide (except-out (all-from-out scheme/base) #%module-begin) (rename-out [module-begin #%module-begin])) -(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase)) +(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase + syntax/strip-context)) (begin-for-syntax (define first-id #f) @@ -14,17 +15,16 @@ (define chunks (make-free-identifier-mapping)) ;; maps a chunk identifier to all identifiers that are used to define it (define chunk-groups (make-free-identifier-mapping)) - (define (get-chunk id) - (map syntax-local-introduce (mapping-get chunks id))) + (define (get-chunk id) (mapping-get chunks id)) (define (add-to-chunk! id exprs) (unless first-id (set! first-id id)) (when (eq? (syntax-e id) '<*>) (set! main-id id)) (free-identifier-mapping-put! chunk-groups id - (cons (syntax-local-introduce id) (mapping-get chunk-groups id))) + (cons id (mapping-get chunk-groups id))) (free-identifier-mapping-put! chunks id - `(,@(mapping-get chunks id) ,@(map syntax-local-introduce exprs))))) + `(,@(mapping-get chunks id) ,@exprs)))) (define-syntax (tangle stx) (define chunk-mentions '()) @@ -53,7 +53,8 @@ [((b-use b-id) ...) (append-map (lambda (m) (map (lambda (u) - (list m (syntax-local-introduce u))) + (list (syntax-local-introduce m) + (syntax-local-introduce u))) (mapping-get chunk-groups m))) chunk-mentions)]) #`(begin body ... (let ([b-id (void)]) b-use) ...))) @@ -77,7 +78,7 @@ [(_ id exprs . body) (let ([expanded (expand `(,#'module scribble-lp-tmp-name scribble/private/lp - ,@(syntax->datum #'(id exprs . body))))]) + ,@(strip-context #'(id exprs . body))))]) (syntax-case expanded () [(module name lang (mb . stuff)) (begin (extract-chunks #'stuff) From d10cdccca9a704f6a215660f667dd7aaaf2c8757 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 26 Feb 2009 14:04:39 +0000 Subject: [PATCH 134/142] fix bitwise ops svn: r13850 --- collects/typed-scheme/private/base-env.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index c8e9b69a41..dea4afdee6 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -395,10 +395,10 @@ [lcm (null -Integer . ->* . -Integer)] [arithmetic-shift (-Integer -Integer . -> . -Integer)] -[bitwise-and (null N . ->* . N)] -[bitwise-ior (null N . ->* . N)] -[bitwise-not (null N . ->* . N)] -[bitwise-xor (null N . ->* . N)] +[bitwise-and (null -Integer . ->* . -Integer)] +[bitwise-ior (null -Integer . ->* . -Integer)] +[bitwise-not (null -Integer . ->* . -Integer)] +[bitwise-xor (null -Integer . ->* . -Integer)] [vector (-poly (a) (->* (list) a (-vec a)))] [make-string (cl-> [(-Integer) -String] [(-Integer -Char) -String])] From 3b53838aed8b37b4ce48ae076ae0232771e810ea Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 26 Feb 2009 16:30:29 +0000 Subject: [PATCH 135/142] finally, a complete draft of the chat noir game in literate programming style svn: r13851 --- .../games/chat-noir/chat-noir-literate.ss | 321 ++++++++++-------- 1 file changed, 177 insertions(+), 144 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 532b893805..1a500a1991 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -45,9 +45,9 @@ The program is divided up into six parts: the world data definition, an implementation of breadth-first search, code that handles drawing of the world, code that handles user input, and some code that builds an initial world and starts the game. - + @chunk[

- (require scheme/local scheme/list scheme/bool scheme/math + (require scheme/list scheme/math lang/private/imageeq ;; don't like this require, but need it for image? (for-syntax scheme/base)) (require 2htdp/universe lang/posn scheme/contract) @@ -89,7 +89,8 @@ The main data structure for Chat Noir is @tt{world}. It comes with a few functio construct empty worlds and test cases for them. @chunk[ - ] + + ] @chunk[ ] @@ -269,47 +270,53 @@ cats initial position as the center spot on the board. #f #f))] +The @scheme[add-n-random-blocked-cells] function accepts a list of cells +and returns a new list of cells where @scheme[n] of the unblocked cells +in @scheme[all-cells] are now blocked. + +If @scheme[n] is zero, of course, no more cells should be blocked, +so the result is just @scheme[all-cells]. Otherwise, +the function computes @scheme[unblocked-cells], a list of all +of the unblocked cells (except the cat's initial location), +and then randomly picks a cell from it, +calling @scheme[block-cell] to actually block that cell. + @chunk[ - - ;; add-n-random-blocked-cells : number (listof cell) number -> (listof cell) - (define (add-n-random-blocked-cells n all-cells board-size) + (define/contract (add-n-random-blocked-cells n all-cells board-size) + (-> natural-number/c (listof cell?) (and/c natural-number/c odd? (>=/c 3)) + (listof cell?)) (cond [(zero? n) all-cells] [else - (local [(define unblocked-cells - (filter (lambda (x) - (let ([cat-cell? (and (= (posn-x (cell-p x)) - (quotient board-size 2)) - (= (posn-y (cell-p x)) - (quotient board-size 2)))]) - - (and (not (cell-blocked? x)) - (not cat-cell?)))) - all-cells)) - (define to-block (list-ref unblocked-cells - (random (length unblocked-cells))))] + (let* ([unblocked-cells + (filter (lambda (x) + (let ([cat-cell? (and (= (posn-x (cell-p x)) + (quotient board-size 2)) + (= (posn-y (cell-p x)) + (quotient board-size 2)))]) + + (and (not (cell-blocked? x)) + (not cat-cell?)))) + all-cells)] + [to-block (list-ref unblocked-cells + (random (length unblocked-cells)))]) (add-n-random-blocked-cells (sub1 n) (block-cell (cell-p to-block) all-cells) board-size))]))] -@chunk[ - (test (block-cell (make-posn 1 1) - (list (make-cell (make-posn 0 0) #f) - (make-cell (make-posn 1 1) #f) - (make-cell (make-posn 2 2) #f))) - (list (make-cell (make-posn 0 0) #f) - (make-cell (make-posn 1 1) #t) - (make-cell (make-posn 2 2) #f))) - - (test (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) - #t)) - 10) - (list (make-cell (make-posn 0 0) #t))) - (test (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) - #f)) - 10) - (list (make-cell (make-posn 0 0) #t)))] + +The @scheme[block-cell] function accepts a @scheme[posn] +and a list of @scheme[cell] structs and updates the +relevant cell, setting its @tt{blocked?} field to @scheme[#t]. + +@chunk[ + (define/contract (block-cell to-block board) + (-> posn? (listof cell?) (listof cell?)) + (map (lambda (c) (if (equal? to-block (cell-p c)) + (make-cell to-block #t) + c)) + board))] @section{Breadth-first Search} @@ -619,8 +626,8 @@ of looking at the board and calculating coordinate offsets. (-> posn? (and/c (listof posn?) (lambda (l) (= 6 (length l))))) - (local [(define x (posn-x p)) - (define y (posn-y p))] + (let ([x (posn-x p)] + [y (posn-y p)]) (cond [(even? y) (list (make-posn (- x 1) (- y 1)) @@ -766,73 +773,73 @@ except it has a smile. @chunk[ (define/contract (cat mode) (-> (or/c 'mad 'happy 'thinking) image?) - (local [(define face-width 36) - (define face-height 22) - - (define face-color - (cond - [(symbol=? mode 'mad) 'pink] - [else 'lightgray])) - - (define left-ear - (regular-polygon 3 8 'solid 'black (/ pi -3))) - (define right-ear - (regular-polygon 3 8 'solid 'black 0)) - (define ear-x-offset 14) - (define ear-y-offset 9) - - (define eye (overlay (ellipse 12 8 'solid 'black) - (ellipse 6 4 'solid 'limegreen))) - (define eye-x-offset 8) - (define eye-y-offset 3) - - (define nose - (regular-polygon 3 5 'solid 'black (/ pi 2))) - - (define mouth-happy - (overlay (ellipse 8 8 'solid face-color) - (ellipse 8 8 'outline 'black) - (move-pinhole - (rectangle 10 5 'solid face-color) - 0 - 4))) - (define mouth-no-expression - (overlay (ellipse 8 8 'solid face-color) - (ellipse 8 8 'outline face-color) - (rectangle 10 5 'solid face-color))) - - (define mouth - (cond - [(symbol=? mode 'happy) mouth-happy] - [else mouth-no-expression])) - (define mouth-x-offset 4) - (define mouth-y-offset -5) - - (define (whiskers img) - (add-line - (add-line - (add-line - (add-line - (add-line - (add-line - img - 6 4 30 12 'black) - 6 4 30 4 'black) - 6 4 30 -4 'black) - -6 4 -30 12 'black) - -6 4 -30 4 'black) - -6 4 -30 -4 'black))] - (whiskers - (overlay - (move-pinhole left-ear (- ear-x-offset) ear-y-offset) - (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) - (ellipse (+ face-width 4) (+ face-height 4) 'solid 'black) - (ellipse face-width face-height 'solid face-color) - (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) - (move-pinhole mouth mouth-x-offset mouth-y-offset) - (move-pinhole eye (- eye-x-offset) eye-y-offset) - (move-pinhole eye eye-x-offset eye-y-offset) - (move-pinhole nose -1 -4))))) + (define face-width 36) + (define face-height 22) + + (define face-color + (cond + [(eq? mode 'mad) 'pink] + [else 'lightgray])) + + (define left-ear + (regular-polygon 3 8 'solid 'black (/ pi -3))) + (define right-ear + (regular-polygon 3 8 'solid 'black 0)) + (define ear-x-offset 14) + (define ear-y-offset 9) + + (define eye (overlay (ellipse 12 8 'solid 'black) + (ellipse 6 4 'solid 'limegreen))) + (define eye-x-offset 8) + (define eye-y-offset 3) + + (define nose + (regular-polygon 3 5 'solid 'black (/ pi 2))) + + (define mouth-happy + (overlay (ellipse 8 8 'solid face-color) + (ellipse 8 8 'outline 'black) + (move-pinhole + (rectangle 10 5 'solid face-color) + 0 + 4))) + (define mouth-no-expression + (overlay (ellipse 8 8 'solid face-color) + (ellipse 8 8 'outline face-color) + (rectangle 10 5 'solid face-color))) + + (define mouth + (cond + [(eq? mode 'happy) mouth-happy] + [else mouth-no-expression])) + (define mouth-x-offset 4) + (define mouth-y-offset -5) + + (define (whiskers img) + (add-line + (add-line + (add-line + (add-line + (add-line + (add-line + img + 6 4 30 12 'black) + 6 4 30 4 'black) + 6 4 30 -4 'black) + -6 4 -30 12 'black) + -6 4 -30 4 'black) + -6 4 -30 -4 'black)) + (whiskers + (overlay + (move-pinhole left-ear (- ear-x-offset) ear-y-offset) + (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) + (ellipse (+ face-width 4) (+ face-height 4) 'solid 'black) + (ellipse face-width face-height 'solid face-color) + (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) + (move-pinhole mouth mouth-x-offset mouth-y-offset) + (move-pinhole eye (- eye-x-offset) eye-y-offset) + (move-pinhole eye eye-x-offset eye-y-offset) + (move-pinhole nose -1 -4)))) (define thinking-cat (cat 'thinking)) (define happy-cat (cat 'happy)) @@ -966,14 +973,14 @@ results in the cell being placed in the right place. @chunk[ (define/contract (render-cell c on-short-path? under-mouse?) (-> cell? boolean? boolean? image?) - (local [(define x (cell-center-x (cell-p c))) - (define y (cell-center-y (cell-p c))) - (define main-circle - (cond - [(cell-blocked? c) - (circle circle-radius 'solid blocked-color)] - [else - (circle circle-radius 'solid normal-color)]))] + (let ([x (cell-center-x (cell-p c))] + [y (cell-center-y (cell-p c))] + [main-circle + (cond + [(cell-blocked? c) + (circle circle-radius 'solid blocked-color)] + [else + (circle circle-radius 'solid normal-color)])]) (move-pinhole (cond [under-mouse? @@ -995,8 +1002,8 @@ and then adding an additional radius. @chunk[ (define/contract (world-width board-size) (-> natural-number/c number?) - (local [(define rightmost-posn - (make-posn (- board-size 1) (- board-size 2)))] + (let ([rightmost-posn + (make-posn (- board-size 1) (- board-size 2))]) (+ (cell-center-x rightmost-posn) circle-radius)))] Similarly, the @scheme[world-height] function computest the @@ -1005,8 +1012,8 @@ height of the rendered world, given the world's size. @chunk[ (define/contract (world-height board-size) (-> natural-number/c number?) - (local [(define bottommost-posn - (make-posn (- board-size 1) (- board-size 1)))] + (let ([bottommost-posn + (make-posn (- board-size 1) (- board-size 1))]) (ceiling (+ (cell-center-y bottommost-posn) circle-radius))))] @@ -1095,7 +1102,6 @@ plus various helper functions. - @@ -1247,18 +1253,6 @@ the @scheme[clack] function blocks the clicked on cell using (world-mouse-posn w) (world-h-down? w)))] -The @scheme[block-cell] function accepts a @scheme[posn] -and a list of @scheme[cell] structs and updates the -relevant cell, setting its @tt{blocked?} field to @scheme[#t]. - -@chunk[ - (define/contract (block-cell to-block board) - (-> posn? (listof cell?) (listof cell?)) - (map (lambda (c) (if (equal? to-block (cell-p c)) - (make-cell to-block #t) - c)) - board))] - The @scheme[move-cat] function uses calls @scheme[build-bfs-table] to find the shortest distance from all of the cells to the boundary, and then uses @scheme[find-best-positions] to compute the @@ -1306,16 +1300,26 @@ position and whether or not the cat won. (world-h-down? world))] +The @scheme[find-best-positions] function accepts +two parallel lists, one of @scheme[posn]s, and one +of scores for those @scheme[posn]s, and it +returns either a non-empty list of @scheme[posn]s +that have tied for the best score, or it +returns @scheme[#f], if the best score is +@scheme['∞]. + @chunk[ - ;; find-best-positions : (nelistof posn) (nelistof number or '∞) - ;; -> (nelistof posn) or #f - (define (find-best-positions posns scores) - (local [(define best-score (foldl (lambda (x sofar) - (if (<=/f x sofar) - x - sofar)) - (first scores) - (rest scores)))] + (define/contract (find-best-positions posns scores) + (-> (cons/c posn? (listof posn?)) + (cons/c (or/c number? '∞) (listof (or/c number? '∞))) + (or/c (cons/c posn? (listof posn?)) #f)) + (let ([best-score + (foldl (lambda (x sofar) + (if (<=/f x sofar) + x + sofar)) + (first scores) + (rest scores))]) (cond [(symbol? best-score) #f] [else @@ -1324,11 +1328,15 @@ position and whether or not the cat won. (filter (lambda (x) (equal? (first x) best-score)) (map list scores posns)))])))] - +This is a helper function that behaves like +@scheme[<=], but is extended to deal properly with +@scheme['∞]. @chunk[ - ;; <=/f : (number or '∞) (number or '∞) -> boolean - (define (<=/f a b) + (define/contract (<=/f a b) + (-> (or/c number? '∞) + (or/c number? '∞) + boolean?) (cond [(equal? b '∞) #t] [(equal? a '∞) #f] @@ -1376,7 +1384,14 @@ is just updated to @scheme[#f]. This section consists of some infrastructure for maintaining tests, plus a pile of additional tests -for the other functions in this document +for the other functions in this document. + +The @scheme[test] and @scheme[test/set] macros +package up their arguments into thunks and then +simply call @scheme[test/proc], supplying +information about the source location of the test +case. The @scheme[test/proc] function runs the tests +and reports the results. @chunk[ @@ -2295,12 +2310,30 @@ for the other functions in this document 0 0) #f)] +@chunk[ + (test (block-cell (make-posn 1 1) + (list (make-cell (make-posn 0 0) #f) + (make-cell (make-posn 1 1) #f) + (make-cell (make-posn 2 2) #f))) + (list (make-cell (make-posn 0 0) #f) + (make-cell (make-posn 1 1) #t) + (make-cell (make-posn 2 2) #f))) + + (test (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) + #t)) + 3) + (list (make-cell (make-posn 0 0) #t))) + (test (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) + #f)) + 3) + (list (make-cell (make-posn 0 0) #t)))] @section{Run, program, run} +This section contains the main expression that starts +the Chat Noir game going. + @chunk[ - (printf "passed ~s tests\n" test-count) (flush-output) - (let* ([board-size 11] [initial-board (add-n-random-blocked-cells From 196ec00f16f726745f98d6d5b026213114d9a5e6 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 26 Feb 2009 17:09:26 +0000 Subject: [PATCH 136/142] new units, contracts, tests svn: r13852 --- collects/html/html-mod.ss | 137 +++ collects/html/html-sig.ss | 12 +- collects/html/html-unit.ss | 275 +++--- collects/html/html.scrbl | 2 +- collects/html/html.ss | 42 +- collects/html/sgml-reader-sig.ss | 8 +- collects/html/sgml-reader-unit.ss | 801 ++++++++------- collects/html/sgml-reader.ss | 429 ++++++++ collects/tests/html/test.ss | 45 + collects/tests/xml/clark-tests/canonxml.html | 44 + .../tests/xml/clark-tests/invalid/001.ent | 3 + .../tests/xml/clark-tests/invalid/001.xml | 2 + .../tests/xml/clark-tests/invalid/002.ent | 2 + .../tests/xml/clark-tests/invalid/002.xml | 2 + .../tests/xml/clark-tests/invalid/003.ent | 2 + .../tests/xml/clark-tests/invalid/003.xml | 2 + .../tests/xml/clark-tests/invalid/004.ent | 3 + .../tests/xml/clark-tests/invalid/004.xml | 2 + .../tests/xml/clark-tests/invalid/005.ent | 2 + .../tests/xml/clark-tests/invalid/005.xml | 2 + .../tests/xml/clark-tests/invalid/006.ent | 2 + .../tests/xml/clark-tests/invalid/006.xml | 2 + .../xml/clark-tests/not-wf/ext-sa/001.ent | 1 + .../xml/clark-tests/not-wf/ext-sa/001.xml | 4 + .../xml/clark-tests/not-wf/ext-sa/002.ent | 3 + .../xml/clark-tests/not-wf/ext-sa/002.xml | 5 + .../xml/clark-tests/not-wf/ext-sa/003.ent | 2 + .../xml/clark-tests/not-wf/ext-sa/003.xml | 5 + .../xml/clark-tests/not-wf/not-sa/001.ent | 3 + .../xml/clark-tests/not-wf/not-sa/001.xml | 2 + .../xml/clark-tests/not-wf/not-sa/002.xml | 6 + .../xml/clark-tests/not-wf/not-sa/003.ent | 2 + .../xml/clark-tests/not-wf/not-sa/003.xml | 2 + .../xml/clark-tests/not-wf/not-sa/004.ent | 2 + .../xml/clark-tests/not-wf/not-sa/004.xml | 2 + .../xml/clark-tests/not-wf/not-sa/005.ent | 2 + .../xml/clark-tests/not-wf/not-sa/005.xml | 2 + .../xml/clark-tests/not-wf/not-sa/006.ent | 3 + .../xml/clark-tests/not-wf/not-sa/006.xml | 2 + .../xml/clark-tests/not-wf/not-sa/007.ent | 3 + .../xml/clark-tests/not-wf/not-sa/007.xml | 2 + .../xml/clark-tests/not-wf/not-sa/008.ent | 2 + .../xml/clark-tests/not-wf/not-sa/008.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/001.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/002.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/003.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/004.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/005.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/006.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/007.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/008.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/009.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/010.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/011.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/012.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/013.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/014.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/015.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/016.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/017.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/018.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/019.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/020.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/021.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/022.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/023.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/024.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/025.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/026.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/027.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/028.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/029.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/030.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/031.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/032.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/033.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/034.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/035.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/036.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/037.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/038.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/039.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/040.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/041.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/042.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/043.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/044.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/045.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/046.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/047.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/048.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/049.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/050.xml | 0 .../tests/xml/clark-tests/not-wf/sa/051.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/052.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/053.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/054.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/055.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/056.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/057.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/058.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/059.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/060.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/061.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/062.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/063.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/064.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/065.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/066.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/067.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/068.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/069.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/070.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/071.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/072.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/073.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/074.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/075.xml | 7 + .../tests/xml/clark-tests/not-wf/sa/076.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/077.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/078.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/079.xml | 8 + .../tests/xml/clark-tests/not-wf/sa/080.xml | 8 + .../tests/xml/clark-tests/not-wf/sa/081.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/082.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/083.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/084.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/085.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/086.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/087.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/088.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/089.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/090.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/091.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/092.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/093.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/094.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/095.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/096.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/097.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/098.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/099.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/100.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/101.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/102.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/103.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/104.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/105.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/106.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/107.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/108.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/109.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/110.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/111.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/112.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/113.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/114.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/115.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/116.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/117.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/118.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/119.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/120.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/121.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/122.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/123.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/124.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/125.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/126.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/127.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/128.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/129.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/130.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/131.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/132.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/133.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/134.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/135.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/136.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/137.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/138.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/139.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/140.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/141.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/142.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/143.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/144.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/145.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/146.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/147.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/148.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/149.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/150.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/151.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/152.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/153.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/154.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/155.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/156.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/157.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/158.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/159.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/160.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/161.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/162.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/163.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/164.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/165.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/166.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/167.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/168.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/169.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/170.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/171.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/172.xml | 2 + .../tests/xml/clark-tests/not-wf/sa/173.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/174.xml | 1 + .../tests/xml/clark-tests/not-wf/sa/175.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/176.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/177.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/178.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/179.xml | 4 + .../tests/xml/clark-tests/not-wf/sa/180.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/181.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/182.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/183.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/184.xml | 6 + .../tests/xml/clark-tests/not-wf/sa/185.ent | 1 + .../tests/xml/clark-tests/not-wf/sa/185.xml | 3 + .../tests/xml/clark-tests/not-wf/sa/186.xml | 5 + .../tests/xml/clark-tests/not-wf/sa/null.ent | 0 collects/tests/xml/clark-tests/readme.html | 60 ++ .../xml/clark-tests/valid/ext-sa/001.ent | 1 + .../xml/clark-tests/valid/ext-sa/001.xml | 5 + .../xml/clark-tests/valid/ext-sa/002.ent | 1 + .../xml/clark-tests/valid/ext-sa/002.xml | 5 + .../xml/clark-tests/valid/ext-sa/003.ent | 0 .../xml/clark-tests/valid/ext-sa/003.xml | 5 + .../xml/clark-tests/valid/ext-sa/004.ent | 1 + .../xml/clark-tests/valid/ext-sa/004.xml | 5 + .../xml/clark-tests/valid/ext-sa/005.ent | 1 + .../xml/clark-tests/valid/ext-sa/005.xml | 6 + .../xml/clark-tests/valid/ext-sa/006.ent | 4 + .../xml/clark-tests/valid/ext-sa/006.xml | 6 + .../xml/clark-tests/valid/ext-sa/007.ent | Bin 0 -> 4 bytes .../xml/clark-tests/valid/ext-sa/007.xml | 5 + .../xml/clark-tests/valid/ext-sa/008.ent | Bin 0 -> 54 bytes .../xml/clark-tests/valid/ext-sa/008.xml | 5 + .../xml/clark-tests/valid/ext-sa/009.ent | 1 + .../xml/clark-tests/valid/ext-sa/009.xml | 5 + .../xml/clark-tests/valid/ext-sa/010.ent | 0 .../xml/clark-tests/valid/ext-sa/010.xml | 5 + .../xml/clark-tests/valid/ext-sa/011.ent | 1 + .../xml/clark-tests/valid/ext-sa/011.xml | 5 + .../xml/clark-tests/valid/ext-sa/012.ent | 1 + .../xml/clark-tests/valid/ext-sa/012.xml | 9 + .../xml/clark-tests/valid/ext-sa/013.ent | 1 + .../xml/clark-tests/valid/ext-sa/013.xml | 10 + .../xml/clark-tests/valid/ext-sa/014.ent | Bin 0 -> 12 bytes .../xml/clark-tests/valid/ext-sa/014.xml | 5 + .../xml/clark-tests/valid/ext-sa/out/001.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/002.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/003.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/004.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/005.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/006.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/007.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/008.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/009.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/010.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/011.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/012.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/013.xml | 1 + .../xml/clark-tests/valid/ext-sa/out/014.xml | 1 + .../xml/clark-tests/valid/not-sa/001.ent | 0 .../xml/clark-tests/valid/not-sa/001.xml | 4 + .../xml/clark-tests/valid/not-sa/002.ent | 1 + .../xml/clark-tests/valid/not-sa/002.xml | 4 + .../xml/clark-tests/valid/not-sa/003-1.ent | 3 + .../xml/clark-tests/valid/not-sa/003-2.ent | 0 .../xml/clark-tests/valid/not-sa/003.xml | 2 + .../xml/clark-tests/valid/not-sa/004-1.ent | 4 + .../xml/clark-tests/valid/not-sa/004-2.ent | 1 + .../xml/clark-tests/valid/not-sa/004.xml | 2 + .../xml/clark-tests/valid/not-sa/005-1.ent | 3 + .../xml/clark-tests/valid/not-sa/005-2.ent | 1 + .../xml/clark-tests/valid/not-sa/005.xml | 2 + .../xml/clark-tests/valid/not-sa/006.ent | 2 + .../xml/clark-tests/valid/not-sa/006.xml | 4 + .../xml/clark-tests/valid/not-sa/007.ent | 2 + .../xml/clark-tests/valid/not-sa/007.xml | 2 + .../xml/clark-tests/valid/not-sa/008.ent | 2 + .../xml/clark-tests/valid/not-sa/008.xml | 2 + .../xml/clark-tests/valid/not-sa/009.ent | 2 + .../xml/clark-tests/valid/not-sa/009.xml | 4 + .../xml/clark-tests/valid/not-sa/010.ent | 2 + .../xml/clark-tests/valid/not-sa/010.xml | 4 + .../xml/clark-tests/valid/not-sa/011.ent | 2 + .../xml/clark-tests/valid/not-sa/011.xml | 5 + .../xml/clark-tests/valid/not-sa/012.ent | 3 + .../xml/clark-tests/valid/not-sa/012.xml | 5 + .../xml/clark-tests/valid/not-sa/013.ent | 4 + .../xml/clark-tests/valid/not-sa/013.xml | 2 + .../xml/clark-tests/valid/not-sa/014.ent | 4 + .../xml/clark-tests/valid/not-sa/014.xml | 4 + .../xml/clark-tests/valid/not-sa/015.ent | 5 + .../xml/clark-tests/valid/not-sa/015.xml | 4 + .../xml/clark-tests/valid/not-sa/016.ent | 4 + .../xml/clark-tests/valid/not-sa/016.xml | 4 + .../xml/clark-tests/valid/not-sa/017.ent | 3 + .../xml/clark-tests/valid/not-sa/017.xml | 2 + .../xml/clark-tests/valid/not-sa/018.ent | 3 + .../xml/clark-tests/valid/not-sa/018.xml | 2 + .../xml/clark-tests/valid/not-sa/019.ent | 3 + .../xml/clark-tests/valid/not-sa/019.xml | 2 + .../xml/clark-tests/valid/not-sa/020.ent | 3 + .../xml/clark-tests/valid/not-sa/020.xml | 2 + .../xml/clark-tests/valid/not-sa/021.ent | 3 + .../xml/clark-tests/valid/not-sa/021.xml | 2 + .../xml/clark-tests/valid/not-sa/022.ent | 3 + .../xml/clark-tests/valid/not-sa/022.xml | 2 + .../xml/clark-tests/valid/not-sa/023.ent | 5 + .../xml/clark-tests/valid/not-sa/023.xml | 2 + .../xml/clark-tests/valid/not-sa/024.ent | 4 + .../xml/clark-tests/valid/not-sa/024.xml | 2 + .../xml/clark-tests/valid/not-sa/025.ent | 5 + .../xml/clark-tests/valid/not-sa/025.xml | 2 + .../xml/clark-tests/valid/not-sa/026.ent | 1 + .../xml/clark-tests/valid/not-sa/026.xml | 7 + .../xml/clark-tests/valid/not-sa/027.ent | 2 + .../xml/clark-tests/valid/not-sa/027.xml | 2 + .../xml/clark-tests/valid/not-sa/028.ent | 2 + .../xml/clark-tests/valid/not-sa/028.xml | 2 + .../xml/clark-tests/valid/not-sa/029.ent | 3 + .../xml/clark-tests/valid/not-sa/029.xml | 2 + .../xml/clark-tests/valid/not-sa/030.ent | 3 + .../xml/clark-tests/valid/not-sa/030.xml | 2 + .../xml/clark-tests/valid/not-sa/031-1.ent | 3 + .../xml/clark-tests/valid/not-sa/031-2.ent | 1 + .../xml/clark-tests/valid/not-sa/031.xml | 2 + .../xml/clark-tests/valid/not-sa/out/001.xml | 1 + .../xml/clark-tests/valid/not-sa/out/002.xml | 1 + .../xml/clark-tests/valid/not-sa/out/003.xml | 1 + .../xml/clark-tests/valid/not-sa/out/004.xml | 1 + .../xml/clark-tests/valid/not-sa/out/005.xml | 1 + .../xml/clark-tests/valid/not-sa/out/006.xml | 1 + .../xml/clark-tests/valid/not-sa/out/007.xml | 1 + .../xml/clark-tests/valid/not-sa/out/008.xml | 1 + .../xml/clark-tests/valid/not-sa/out/009.xml | 1 + .../xml/clark-tests/valid/not-sa/out/010.xml | 1 + .../xml/clark-tests/valid/not-sa/out/011.xml | 1 + .../xml/clark-tests/valid/not-sa/out/012.xml | 1 + .../xml/clark-tests/valid/not-sa/out/013.xml | 1 + .../xml/clark-tests/valid/not-sa/out/014.xml | 1 + .../xml/clark-tests/valid/not-sa/out/015.xml | 1 + .../xml/clark-tests/valid/not-sa/out/016.xml | 1 + .../xml/clark-tests/valid/not-sa/out/017.xml | 1 + .../xml/clark-tests/valid/not-sa/out/018.xml | 1 + .../xml/clark-tests/valid/not-sa/out/019.xml | 1 + .../xml/clark-tests/valid/not-sa/out/020.xml | 1 + .../xml/clark-tests/valid/not-sa/out/021.xml | 1 + .../xml/clark-tests/valid/not-sa/out/022.xml | 1 + .../xml/clark-tests/valid/not-sa/out/023.xml | 1 + .../xml/clark-tests/valid/not-sa/out/024.xml | 1 + .../xml/clark-tests/valid/not-sa/out/025.xml | 1 + .../xml/clark-tests/valid/not-sa/out/026.xml | 1 + .../xml/clark-tests/valid/not-sa/out/027.xml | 1 + .../xml/clark-tests/valid/not-sa/out/028.xml | 1 + .../xml/clark-tests/valid/not-sa/out/029.xml | 1 + .../xml/clark-tests/valid/not-sa/out/030.xml | 1 + .../xml/clark-tests/valid/not-sa/out/031.xml | 1 + .../tests/xml/clark-tests/valid/sa/001.xml | 4 + .../tests/xml/clark-tests/valid/sa/002.xml | 4 + .../tests/xml/clark-tests/valid/sa/003.xml | 4 + .../tests/xml/clark-tests/valid/sa/004.xml | 5 + .../tests/xml/clark-tests/valid/sa/005.xml | 5 + .../tests/xml/clark-tests/valid/sa/006.xml | 5 + .../tests/xml/clark-tests/valid/sa/007.xml | 4 + .../tests/xml/clark-tests/valid/sa/008.xml | 4 + .../tests/xml/clark-tests/valid/sa/009.xml | 4 + .../tests/xml/clark-tests/valid/sa/010.xml | 5 + .../tests/xml/clark-tests/valid/sa/011.xml | 5 + .../tests/xml/clark-tests/valid/sa/012.xml | 5 + .../tests/xml/clark-tests/valid/sa/013.xml | 5 + .../tests/xml/clark-tests/valid/sa/014.xml | 5 + .../tests/xml/clark-tests/valid/sa/015.xml | 5 + .../tests/xml/clark-tests/valid/sa/016.xml | 4 + .../tests/xml/clark-tests/valid/sa/017.xml | 4 + .../tests/xml/clark-tests/valid/sa/018.xml | 4 + .../tests/xml/clark-tests/valid/sa/019.xml | 4 + .../tests/xml/clark-tests/valid/sa/020.xml | 4 + .../tests/xml/clark-tests/valid/sa/021.xml | 4 + .../tests/xml/clark-tests/valid/sa/022.xml | 4 + .../tests/xml/clark-tests/valid/sa/023.xml | 5 + .../tests/xml/clark-tests/valid/sa/024.xml | 6 + .../tests/xml/clark-tests/valid/sa/025.xml | 5 + .../tests/xml/clark-tests/valid/sa/026.xml | 5 + .../tests/xml/clark-tests/valid/sa/027.xml | 5 + .../tests/xml/clark-tests/valid/sa/028.xml | 5 + .../tests/xml/clark-tests/valid/sa/029.xml | 5 + .../tests/xml/clark-tests/valid/sa/030.xml | 5 + .../tests/xml/clark-tests/valid/sa/031.xml | 5 + .../tests/xml/clark-tests/valid/sa/032.xml | 5 + .../tests/xml/clark-tests/valid/sa/033.xml | 5 + .../tests/xml/clark-tests/valid/sa/034.xml | 4 + .../tests/xml/clark-tests/valid/sa/035.xml | 4 + .../tests/xml/clark-tests/valid/sa/036.xml | 5 + .../tests/xml/clark-tests/valid/sa/037.xml | 6 + .../tests/xml/clark-tests/valid/sa/038.xml | 6 + .../tests/xml/clark-tests/valid/sa/039.xml | 5 + .../tests/xml/clark-tests/valid/sa/040.xml | 5 + .../tests/xml/clark-tests/valid/sa/041.xml | 5 + .../tests/xml/clark-tests/valid/sa/042.xml | 4 + .../tests/xml/clark-tests/valid/sa/043.xml | 6 + .../tests/xml/clark-tests/valid/sa/044.xml | 10 + .../tests/xml/clark-tests/valid/sa/045.xml | 6 + .../tests/xml/clark-tests/valid/sa/046.xml | 6 + .../tests/xml/clark-tests/valid/sa/047.xml | 5 + .../tests/xml/clark-tests/valid/sa/048.xml | 4 + .../tests/xml/clark-tests/valid/sa/049.xml | Bin 0 -> 124 bytes .../tests/xml/clark-tests/valid/sa/050.xml | Bin 0 -> 132 bytes .../tests/xml/clark-tests/valid/sa/051.xml | Bin 0 -> 140 bytes .../tests/xml/clark-tests/valid/sa/052.xml | 4 + .../tests/xml/clark-tests/valid/sa/053.xml | 6 + .../tests/xml/clark-tests/valid/sa/054.xml | 10 + .../tests/xml/clark-tests/valid/sa/055.xml | 5 + .../tests/xml/clark-tests/valid/sa/056.xml | 4 + .../tests/xml/clark-tests/valid/sa/057.xml | 4 + .../tests/xml/clark-tests/valid/sa/058.xml | 5 + .../tests/xml/clark-tests/valid/sa/059.xml | 10 + .../tests/xml/clark-tests/valid/sa/060.xml | 4 + .../tests/xml/clark-tests/valid/sa/061.xml | 4 + .../tests/xml/clark-tests/valid/sa/062.xml | 4 + .../tests/xml/clark-tests/valid/sa/063.xml | 4 + .../tests/xml/clark-tests/valid/sa/064.xml | 4 + .../tests/xml/clark-tests/valid/sa/065.xml | 5 + .../tests/xml/clark-tests/valid/sa/066.xml | 7 + .../tests/xml/clark-tests/valid/sa/067.xml | 4 + .../tests/xml/clark-tests/valid/sa/068.xml | 5 + .../tests/xml/clark-tests/valid/sa/069.xml | 5 + .../tests/xml/clark-tests/valid/sa/070.xml | 5 + .../tests/xml/clark-tests/valid/sa/071.xml | 5 + .../tests/xml/clark-tests/valid/sa/072.xml | 5 + .../tests/xml/clark-tests/valid/sa/073.xml | 5 + .../tests/xml/clark-tests/valid/sa/074.xml | 5 + .../tests/xml/clark-tests/valid/sa/075.xml | 5 + .../tests/xml/clark-tests/valid/sa/076.xml | 7 + .../tests/xml/clark-tests/valid/sa/077.xml | 5 + .../tests/xml/clark-tests/valid/sa/078.xml | 5 + .../tests/xml/clark-tests/valid/sa/079.xml | 5 + .../tests/xml/clark-tests/valid/sa/080.xml | 5 + .../tests/xml/clark-tests/valid/sa/081.xml | 7 + .../tests/xml/clark-tests/valid/sa/082.xml | 5 + .../tests/xml/clark-tests/valid/sa/083.xml | 5 + .../tests/xml/clark-tests/valid/sa/084.xml | 1 + .../tests/xml/clark-tests/valid/sa/085.xml | 6 + .../tests/xml/clark-tests/valid/sa/086.xml | 6 + .../tests/xml/clark-tests/valid/sa/087.xml | 6 + .../tests/xml/clark-tests/valid/sa/088.xml | 5 + .../tests/xml/clark-tests/valid/sa/089.xml | 5 + .../tests/xml/clark-tests/valid/sa/090.xml | 7 + .../tests/xml/clark-tests/valid/sa/091.xml | 7 + .../tests/xml/clark-tests/valid/sa/092.xml | 10 + .../tests/xml/clark-tests/valid/sa/093.xml | 5 + .../tests/xml/clark-tests/valid/sa/094.xml | 6 + .../tests/xml/clark-tests/valid/sa/095.xml | 6 + .../tests/xml/clark-tests/valid/sa/096.xml | 5 + .../tests/xml/clark-tests/valid/sa/097.ent | 1 + .../tests/xml/clark-tests/valid/sa/097.xml | 8 + .../tests/xml/clark-tests/valid/sa/098.xml | 5 + .../tests/xml/clark-tests/valid/sa/099.xml | 5 + .../tests/xml/clark-tests/valid/sa/100.xml | 5 + .../tests/xml/clark-tests/valid/sa/101.xml | 5 + .../tests/xml/clark-tests/valid/sa/102.xml | 5 + .../tests/xml/clark-tests/valid/sa/103.xml | 4 + .../tests/xml/clark-tests/valid/sa/104.xml | 5 + .../tests/xml/clark-tests/valid/sa/105.xml | 5 + .../tests/xml/clark-tests/valid/sa/106.xml | 5 + .../tests/xml/clark-tests/valid/sa/107.xml | 5 + .../tests/xml/clark-tests/valid/sa/108.xml | 7 + .../tests/xml/clark-tests/valid/sa/109.xml | 5 + .../tests/xml/clark-tests/valid/sa/110.xml | 6 + .../tests/xml/clark-tests/valid/sa/111.xml | 5 + .../tests/xml/clark-tests/valid/sa/112.xml | 5 + .../tests/xml/clark-tests/valid/sa/113.xml | 5 + .../tests/xml/clark-tests/valid/sa/114.xml | 5 + .../tests/xml/clark-tests/valid/sa/115.xml | 6 + .../tests/xml/clark-tests/valid/sa/116.xml | 5 + .../tests/xml/clark-tests/valid/sa/117.xml | 5 + .../tests/xml/clark-tests/valid/sa/118.xml | 5 + .../tests/xml/clark-tests/valid/sa/119.xml | 4 + .../xml/clark-tests/valid/sa/out/001.xml | 1 + .../xml/clark-tests/valid/sa/out/002.xml | 1 + .../xml/clark-tests/valid/sa/out/003.xml | 1 + .../xml/clark-tests/valid/sa/out/004.xml | 1 + .../xml/clark-tests/valid/sa/out/005.xml | 1 + .../xml/clark-tests/valid/sa/out/006.xml | 1 + .../xml/clark-tests/valid/sa/out/007.xml | 1 + .../xml/clark-tests/valid/sa/out/008.xml | 1 + .../xml/clark-tests/valid/sa/out/009.xml | 1 + .../xml/clark-tests/valid/sa/out/010.xml | 1 + .../xml/clark-tests/valid/sa/out/011.xml | 1 + .../xml/clark-tests/valid/sa/out/012.xml | 1 + .../xml/clark-tests/valid/sa/out/013.xml | 1 + .../xml/clark-tests/valid/sa/out/014.xml | 1 + .../xml/clark-tests/valid/sa/out/015.xml | 1 + .../xml/clark-tests/valid/sa/out/016.xml | 1 + .../xml/clark-tests/valid/sa/out/017.xml | 1 + .../xml/clark-tests/valid/sa/out/018.xml | 1 + .../xml/clark-tests/valid/sa/out/019.xml | 1 + .../xml/clark-tests/valid/sa/out/020.xml | 1 + .../xml/clark-tests/valid/sa/out/021.xml | 1 + .../xml/clark-tests/valid/sa/out/022.xml | 1 + .../xml/clark-tests/valid/sa/out/023.xml | 1 + .../xml/clark-tests/valid/sa/out/024.xml | 1 + .../xml/clark-tests/valid/sa/out/025.xml | 1 + .../xml/clark-tests/valid/sa/out/026.xml | 1 + .../xml/clark-tests/valid/sa/out/027.xml | 1 + .../xml/clark-tests/valid/sa/out/028.xml | 1 + .../xml/clark-tests/valid/sa/out/029.xml | 1 + .../xml/clark-tests/valid/sa/out/030.xml | 1 + .../xml/clark-tests/valid/sa/out/031.xml | 1 + .../xml/clark-tests/valid/sa/out/032.xml | 1 + .../xml/clark-tests/valid/sa/out/033.xml | 1 + .../xml/clark-tests/valid/sa/out/034.xml | 1 + .../xml/clark-tests/valid/sa/out/035.xml | 1 + .../xml/clark-tests/valid/sa/out/036.xml | 1 + .../xml/clark-tests/valid/sa/out/037.xml | 1 + .../xml/clark-tests/valid/sa/out/038.xml | 1 + .../xml/clark-tests/valid/sa/out/039.xml | 1 + .../xml/clark-tests/valid/sa/out/040.xml | 1 + .../xml/clark-tests/valid/sa/out/041.xml | 1 + .../xml/clark-tests/valid/sa/out/042.xml | 1 + .../xml/clark-tests/valid/sa/out/043.xml | 1 + .../xml/clark-tests/valid/sa/out/044.xml | 1 + .../xml/clark-tests/valid/sa/out/045.xml | 1 + .../xml/clark-tests/valid/sa/out/046.xml | 1 + .../xml/clark-tests/valid/sa/out/047.xml | 1 + .../xml/clark-tests/valid/sa/out/048.xml | 1 + .../xml/clark-tests/valid/sa/out/049.xml | 1 + .../xml/clark-tests/valid/sa/out/050.xml | 1 + .../xml/clark-tests/valid/sa/out/051.xml | 1 + .../xml/clark-tests/valid/sa/out/052.xml | 1 + .../xml/clark-tests/valid/sa/out/053.xml | 1 + .../xml/clark-tests/valid/sa/out/054.xml | 1 + .../xml/clark-tests/valid/sa/out/055.xml | 1 + .../xml/clark-tests/valid/sa/out/056.xml | 1 + .../xml/clark-tests/valid/sa/out/057.xml | 1 + .../xml/clark-tests/valid/sa/out/058.xml | 1 + .../xml/clark-tests/valid/sa/out/059.xml | 1 + .../xml/clark-tests/valid/sa/out/060.xml | 1 + .../xml/clark-tests/valid/sa/out/061.xml | 1 + .../xml/clark-tests/valid/sa/out/062.xml | 1 + .../xml/clark-tests/valid/sa/out/063.xml | 1 + .../xml/clark-tests/valid/sa/out/064.xml | 1 + .../xml/clark-tests/valid/sa/out/065.xml | 1 + .../xml/clark-tests/valid/sa/out/066.xml | 1 + .../xml/clark-tests/valid/sa/out/067.xml | 1 + .../xml/clark-tests/valid/sa/out/068.xml | 1 + .../xml/clark-tests/valid/sa/out/069.xml | 1 + .../xml/clark-tests/valid/sa/out/070.xml | 1 + .../xml/clark-tests/valid/sa/out/071.xml | 1 + .../xml/clark-tests/valid/sa/out/072.xml | 1 + .../xml/clark-tests/valid/sa/out/073.xml | 1 + .../xml/clark-tests/valid/sa/out/074.xml | 1 + .../xml/clark-tests/valid/sa/out/075.xml | 1 + .../xml/clark-tests/valid/sa/out/076.xml | 1 + .../xml/clark-tests/valid/sa/out/077.xml | 1 + .../xml/clark-tests/valid/sa/out/078.xml | 1 + .../xml/clark-tests/valid/sa/out/079.xml | 1 + .../xml/clark-tests/valid/sa/out/080.xml | 1 + .../xml/clark-tests/valid/sa/out/081.xml | 1 + .../xml/clark-tests/valid/sa/out/082.xml | 1 + .../xml/clark-tests/valid/sa/out/083.xml | 1 + .../xml/clark-tests/valid/sa/out/084.xml | 1 + .../xml/clark-tests/valid/sa/out/085.xml | 1 + .../xml/clark-tests/valid/sa/out/086.xml | 1 + .../xml/clark-tests/valid/sa/out/087.xml | 1 + .../xml/clark-tests/valid/sa/out/088.xml | 1 + .../xml/clark-tests/valid/sa/out/089.xml | 1 + .../xml/clark-tests/valid/sa/out/090.xml | 1 + .../xml/clark-tests/valid/sa/out/091.xml | 1 + .../xml/clark-tests/valid/sa/out/092.xml | 1 + .../xml/clark-tests/valid/sa/out/093.xml | 1 + .../xml/clark-tests/valid/sa/out/094.xml | 1 + .../xml/clark-tests/valid/sa/out/095.xml | 1 + .../xml/clark-tests/valid/sa/out/096.xml | 1 + .../xml/clark-tests/valid/sa/out/097.xml | 1 + .../xml/clark-tests/valid/sa/out/098.xml | 2 + .../xml/clark-tests/valid/sa/out/099.xml | 1 + .../xml/clark-tests/valid/sa/out/100.xml | 1 + .../xml/clark-tests/valid/sa/out/101.xml | 1 + .../xml/clark-tests/valid/sa/out/102.xml | 1 + .../xml/clark-tests/valid/sa/out/103.xml | 1 + .../xml/clark-tests/valid/sa/out/104.xml | 1 + .../xml/clark-tests/valid/sa/out/105.xml | 1 + .../xml/clark-tests/valid/sa/out/106.xml | 1 + .../xml/clark-tests/valid/sa/out/107.xml | 1 + .../xml/clark-tests/valid/sa/out/108.xml | 1 + .../xml/clark-tests/valid/sa/out/109.xml | 1 + .../xml/clark-tests/valid/sa/out/110.xml | 1 + .../xml/clark-tests/valid/sa/out/111.xml | 1 + .../xml/clark-tests/valid/sa/out/112.xml | 1 + .../xml/clark-tests/valid/sa/out/113.xml | 1 + .../xml/clark-tests/valid/sa/out/114.xml | 1 + .../xml/clark-tests/valid/sa/out/115.xml | 1 + .../xml/clark-tests/valid/sa/out/116.xml | 1 + .../xml/clark-tests/valid/sa/out/117.xml | 1 + .../xml/clark-tests/valid/sa/out/118.xml | 1 + .../xml/clark-tests/valid/sa/out/119.xml | 1 + collects/tests/xml/test-clark.ss | 90 ++ collects/tests/xml/test.ss | 392 +++++--- collects/tests/xml/to-list.ss | 4 +- collects/xml/plist.ss | 329 +++---- collects/xml/private/reader.ss | 914 +++++++++--------- collects/xml/private/sig.ss | 139 +-- collects/xml/private/space.ss | 69 +- collects/xml/private/structures.ss | 153 ++- collects/xml/private/syntax.ss | 421 ++++---- collects/xml/private/writer.ss | 333 ++++--- collects/xml/private/xexpr.ss | 443 +++++---- collects/xml/xml-sig.ss | 27 +- collects/xml/xml-unit.ss | 94 +- collects/xml/xml.scrbl | 19 +- collects/xml/xml.ss | 13 +- 625 files changed, 4848 insertions(+), 2172 deletions(-) create mode 100644 collects/html/html-mod.ss create mode 100644 collects/html/sgml-reader.ss create mode 100644 collects/tests/html/test.ss create mode 100644 collects/tests/xml/clark-tests/canonxml.html create mode 100644 collects/tests/xml/clark-tests/invalid/001.ent create mode 100644 collects/tests/xml/clark-tests/invalid/001.xml create mode 100644 collects/tests/xml/clark-tests/invalid/002.ent create mode 100644 collects/tests/xml/clark-tests/invalid/002.xml create mode 100644 collects/tests/xml/clark-tests/invalid/003.ent create mode 100644 collects/tests/xml/clark-tests/invalid/003.xml create mode 100644 collects/tests/xml/clark-tests/invalid/004.ent create mode 100644 collects/tests/xml/clark-tests/invalid/004.xml create mode 100644 collects/tests/xml/clark-tests/invalid/005.ent create mode 100644 collects/tests/xml/clark-tests/invalid/005.xml create mode 100644 collects/tests/xml/clark-tests/invalid/006.ent create mode 100644 collects/tests/xml/clark-tests/invalid/006.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/001.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/001.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/002.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/003.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/003.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/004.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/004.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/005.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/005.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/006.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/006.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/007.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/007.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/008.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/not-sa/008.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/001.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/002.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/003.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/004.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/005.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/006.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/007.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/008.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/009.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/010.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/011.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/012.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/013.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/014.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/015.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/016.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/017.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/018.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/019.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/020.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/021.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/022.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/023.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/024.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/025.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/026.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/027.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/028.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/029.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/030.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/031.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/032.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/033.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/034.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/035.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/036.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/037.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/038.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/039.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/040.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/041.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/042.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/043.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/044.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/045.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/046.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/047.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/048.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/049.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/050.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/051.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/052.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/053.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/054.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/055.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/056.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/057.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/058.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/059.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/060.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/061.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/062.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/063.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/064.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/065.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/066.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/067.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/068.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/069.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/070.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/071.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/072.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/073.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/074.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/075.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/076.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/077.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/078.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/079.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/080.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/081.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/082.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/083.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/084.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/085.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/086.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/087.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/088.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/089.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/090.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/091.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/092.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/093.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/094.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/095.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/096.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/097.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/098.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/099.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/100.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/101.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/102.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/103.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/104.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/105.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/106.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/107.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/108.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/109.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/110.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/111.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/112.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/113.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/114.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/115.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/116.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/117.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/118.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/119.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/120.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/121.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/122.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/123.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/124.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/125.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/126.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/127.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/128.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/129.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/130.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/131.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/132.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/133.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/134.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/135.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/136.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/137.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/138.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/139.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/140.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/141.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/142.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/143.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/144.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/145.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/146.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/147.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/148.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/149.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/150.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/151.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/152.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/153.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/154.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/155.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/156.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/157.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/158.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/159.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/160.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/161.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/162.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/163.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/164.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/165.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/166.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/167.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/168.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/169.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/170.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/171.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/172.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/173.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/174.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/175.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/176.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/177.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/178.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/179.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/180.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/181.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/182.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/183.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/184.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/185.ent create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/185.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/186.xml create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/null.ent create mode 100644 collects/tests/xml/clark-tests/readme.html create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/001.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/001.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/002.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/002.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/003.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/003.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/004.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/004.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/005.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/005.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/006.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/006.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/007.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/007.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/008.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/008.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/009.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/009.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/010.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/010.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/011.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/011.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/012.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/012.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/013.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/013.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/014.ent create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/014.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/001.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/002.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/003.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/004.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/005.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/006.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/007.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/008.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/009.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/010.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/011.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/012.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/013.xml create mode 100644 collects/tests/xml/clark-tests/valid/ext-sa/out/014.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/001.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/001.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/002.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/002.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/003-1.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/003-2.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/003.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/004-1.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/004-2.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/004.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/005-1.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/005-2.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/005.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/006.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/006.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/007.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/007.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/008.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/008.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/009.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/009.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/010.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/010.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/011.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/011.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/012.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/012.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/013.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/013.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/014.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/014.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/015.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/015.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/016.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/016.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/017.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/017.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/018.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/018.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/019.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/019.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/020.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/020.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/021.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/021.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/022.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/022.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/023.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/023.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/024.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/024.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/025.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/025.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/026.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/026.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/027.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/027.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/028.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/028.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/029.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/029.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/030.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/030.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/031-1.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/031-2.ent create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/031.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/001.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/002.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/003.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/004.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/005.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/006.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/007.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/008.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/009.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/010.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/011.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/012.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/013.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/014.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/015.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/016.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/017.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/018.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/019.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/020.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/021.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/022.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/023.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/024.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/025.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/026.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/027.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/028.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/029.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/030.xml create mode 100644 collects/tests/xml/clark-tests/valid/not-sa/out/031.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/001.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/002.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/003.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/004.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/005.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/006.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/007.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/008.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/009.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/010.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/011.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/012.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/013.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/014.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/015.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/016.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/017.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/018.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/019.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/020.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/021.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/022.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/023.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/024.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/025.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/026.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/027.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/028.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/029.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/030.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/031.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/032.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/033.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/034.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/035.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/036.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/037.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/038.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/039.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/040.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/041.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/042.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/043.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/044.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/045.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/046.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/047.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/048.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/049.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/050.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/051.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/052.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/053.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/054.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/055.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/056.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/057.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/058.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/059.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/060.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/061.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/062.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/063.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/064.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/065.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/066.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/067.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/068.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/069.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/070.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/071.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/072.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/073.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/074.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/075.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/076.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/077.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/078.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/079.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/080.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/081.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/082.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/083.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/084.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/085.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/086.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/087.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/088.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/089.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/090.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/091.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/092.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/093.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/094.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/095.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/096.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/097.ent create mode 100644 collects/tests/xml/clark-tests/valid/sa/097.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/098.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/099.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/100.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/101.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/102.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/103.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/104.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/105.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/106.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/107.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/108.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/109.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/110.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/111.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/112.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/113.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/114.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/115.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/116.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/117.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/118.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/119.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/001.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/002.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/003.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/004.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/005.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/006.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/007.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/008.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/009.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/010.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/011.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/012.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/013.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/014.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/015.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/016.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/017.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/018.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/019.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/020.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/021.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/022.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/023.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/024.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/025.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/026.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/027.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/028.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/029.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/030.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/031.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/032.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/033.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/034.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/035.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/036.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/037.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/038.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/039.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/040.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/041.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/042.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/043.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/044.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/045.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/046.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/047.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/048.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/049.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/050.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/051.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/052.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/053.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/054.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/055.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/056.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/057.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/058.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/059.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/060.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/061.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/062.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/063.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/064.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/065.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/066.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/067.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/068.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/069.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/070.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/071.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/072.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/073.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/074.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/075.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/076.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/077.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/078.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/079.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/080.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/081.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/082.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/083.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/084.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/085.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/086.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/087.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/088.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/089.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/090.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/091.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/092.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/093.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/094.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/095.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/096.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/097.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/098.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/099.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/100.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/101.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/102.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/103.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/104.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/105.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/106.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/107.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/108.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/109.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/110.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/111.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/112.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/113.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/114.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/115.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/116.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/117.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/118.xml create mode 100644 collects/tests/xml/clark-tests/valid/sa/out/119.xml create mode 100644 collects/tests/xml/test-clark.ss diff --git a/collects/html/html-mod.ss b/collects/html/html-mod.ss new file mode 100644 index 0000000000..49a6f71b9e --- /dev/null +++ b/collects/html/html-mod.ss @@ -0,0 +1,137 @@ +#lang scheme +;; copyright by Paul Graunke June 2000 AD + +(require mzlib/file + mzlib/list + mzlib/etc + mzlib/include + "html-spec.ss" + "html-sig.ss" + (prefix-in sgml: "sgml-reader.ss") + xml) + +(provide-signature-elements html^) + + ;; Html-content = Html-element | Pc-data | Entity + + (include "html-structs.ss") + (include "case.ss") + + ;; xml->html : Document -> Html + (define (xml->html doc) + (let ([root (document-element doc)]) + (unless (eq? 'html (element-name root)) + (error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root))) + (make-html (element-attributes root) (xml-contents->html (element-content root))))) + + + ;; xml-content->html : (listof Content) -> (listof Html-element) + (define (xml-contents->html contents) + (foldr xml-single-content->html + null + contents)) + + ;; read-xhtml : [Input-port] -> Html + (define read-xhtml (compose xml->html read-xml)) + + ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content) + (define (peel-f toss? to-toss acc0) + (foldr (lambda (x acc) + (if (toss? x) + (append (html-full-content x) acc) + (cons x acc))) + acc0 + to-toss)) + + ;; repackage-html : (listof Html-content) -> Html + (define (repackage-html contents) + (let* ([html (memf html? contents)] + [peeled (peel-f html? contents null)] + [body (memf body? peeled)]) + (make-html (if html + (html-element-attributes (car html)) + null) + (append (filter head? peeled) + (list (make-body (if body + (html-element-attributes (car body)) + null) + (filter (compose not head?) (peel-f body? peeled null)))))))) + + ;; clean-up-pcdata : (listof Content) -> (listof Content) + ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either + ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata + ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata + ;; c) discarded + ;; unknown tags may contain pcdata + ;; the top level may contain pcdata + (define clean-up-pcdata + ;; clean-up-pcdata : (listof Content) -> (listof Content) + (letrec ([clean-up-pcdata + (lambda (content) + (map (lambda (to-fix) + (cond + [(element? to-fix) + (recontent-xml to-fix + (let ([possible (may-contain (element-name to-fix))] + [content (element-content to-fix)]) + (if (or (not possible) (memq 'pcdata possible)) + (clean-up-pcdata content) + (eliminate-pcdata content))))] + [else to-fix])) + content))] + [eliminate-pcdata + ;: (listof Content) -> (listof Content) + (lambda (content) + (let ([non-elements (first-non-elements content)] + [more (memf element? content)]) + (if more + (let* ([el (car more)] + [possible (may-contain (element-name el))]) + (if (or (not possible) (memq 'pcdata possible)) + (cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more))))) + (or (memf element? (cdr more)) null)) + (cons (recontent-xml el (eliminate-pcdata (element-content el))) + (eliminate-pcdata (cdr more))))) + null)))]) + clean-up-pcdata)) + + ;; first-non-elements : (listof Content) -> (listof Content) + (define (first-non-elements content) + (cond + [(null? content) null] + [else (if (element? (car content)) + null + (cons (car content) (first-non-elements (cdr content))))])) + + ;; recontent-xml : Element (listof Content) -> Element + (define (recontent-xml e c) + (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c)) + + ;; implicit-starts : Symbol Symbol -> (U #f Symbol) + (define (implicit-starts parent child) + (or (and (eq? child 'tr) (eq? parent 'table) 'tbody) + (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr))) + + ;; may-contain : Kid-lister + (define may-contain + (sgml:gen-may-contain html-spec)) + + (define may-contain-anything + (sgml:gen-may-contain null)) + + (define use-html-spec (make-parameter #t)) + + ;; read-html-as-xml : [Input-port] -> (listof Content) + (define read-html-as-xml + (case-lambda + [(port) + ((if (use-html-spec) clean-up-pcdata values) + ((sgml:gen-read-sgml (if (use-html-spec) + may-contain + may-contain-anything) + implicit-starts) port))] + [() (read-html-as-xml (current-input-port))])) + + ;; read-html : [Input-port] -> Html + (define read-html + (compose repackage-html xml-contents->html read-html-as-xml)) \ No newline at end of file diff --git a/collects/html/html-sig.ss b/collects/html/html-sig.ss index d0b57a7e23..600cff884a 100644 --- a/collects/html/html-sig.ss +++ b/collects/html/html-sig.ss @@ -1,11 +1,9 @@ ;; copyright by Paul Graunke June 2000 AD +#lang scheme -(module html-sig mzscheme - (require mzlib/unitsig) +(define-signature html-structs^ ((struct html-element (attributes)) (struct html-full (content)) (struct html ()) (struct div ()) (struct center ()) (struct blockquote ()) (struct ins ()) (struct del ()) (struct dd ()) (struct li ()) (struct th ()) (struct td ()) (struct iframe ()) (struct noframes ()) (struct noscript ()) (struct style ()) (struct script ()) (struct basefont ()) (struct br ()) (struct area ()) (struct link ()) (struct img ()) (struct param ()) (struct hr ()) (struct input ()) (struct col ()) (struct isindex ()) (struct base ()) (struct meta ()) (struct option ()) (struct textarea ()) (struct title ()) (struct head ()) (struct tr ()) (struct colgroup ()) (struct thead ()) (struct tfoot ()) (struct tbody ()) (struct tt ()) (struct i ()) (struct b ()) (struct u ()) (struct s ()) (struct strike ()) (struct big ()) (struct small ()) (struct em ()) (struct strong ()) (struct dfn ()) (struct code ()) (struct samp ()) (struct kbd ()) (struct var ()) (struct cite ()) (struct abbr ()) (struct acronym ()) (struct sub ()) (struct sup ()) (struct span ()) (struct bdo ()) (struct font ()) (struct p ()) (struct h1 ()) (struct h2 ()) (struct h3 ()) (struct h4 ()) (struct h5 ()) (struct h6 ()) (struct q ()) (struct dt ()) (struct legend ()) (struct caption ()) (struct table ()) (struct button ()) (struct fieldset ()) (struct optgroup ()) (struct select ()) (struct label ()) (struct form ()) (struct ol ()) (struct ul ()) (struct dir ()) (struct menu ()) (struct dl ()) (struct pre ()) (struct object ()) (struct applet ()) (struct -map ()) (struct a ()) (struct address ()) (struct body ()))) - (define-signature html-structs^ ((struct html-element (attributes)) (struct html-full (content)) (struct html ()) (struct div ()) (struct center ()) (struct blockquote ()) (struct ins ()) (struct del ()) (struct dd ()) (struct li ()) (struct th ()) (struct td ()) (struct iframe ()) (struct noframes ()) (struct noscript ()) (struct style ()) (struct script ()) (struct basefont ()) (struct br ()) (struct area ()) (struct link ()) (struct img ()) (struct param ()) (struct hr ()) (struct input ()) (struct col ()) (struct isindex ()) (struct base ()) (struct meta ()) (struct option ()) (struct textarea ()) (struct title ()) (struct head ()) (struct tr ()) (struct colgroup ()) (struct thead ()) (struct tfoot ()) (struct tbody ()) (struct tt ()) (struct i ()) (struct b ()) (struct u ()) (struct s ()) (struct strike ()) (struct big ()) (struct small ()) (struct em ()) (struct strong ()) (struct dfn ()) (struct code ()) (struct samp ()) (struct kbd ()) (struct var ()) (struct cite ()) (struct abbr ()) (struct acronym ()) (struct sub ()) (struct sup ()) (struct span ()) (struct bdo ()) (struct font ()) (struct p ()) (struct h1 ()) (struct h2 ()) (struct h3 ()) (struct h4 ()) (struct h5 ()) (struct h6 ()) (struct q ()) (struct dt ()) (struct legend ()) (struct caption ()) (struct table ()) (struct button ()) (struct fieldset ()) (struct optgroup ()) (struct select ()) (struct label ()) (struct form ()) (struct ol ()) (struct ul ()) (struct dir ()) (struct menu ()) (struct dl ()) (struct pre ()) (struct object ()) (struct applet ()) (struct -map ()) (struct a ()) (struct address ()) (struct body ()))) +(define-signature html^ (read-xhtml read-html read-html-as-xml (open html-structs^) + use-html-spec)) - (define-signature html^ (read-xhtml read-html read-html-as-xml (open html-structs^) - use-html-spec)) - - (provide html^)) +(provide html^) \ No newline at end of file diff --git a/collects/html/html-unit.ss b/collects/html/html-unit.ss index ce4927b3dc..ae540f38cb 100644 --- a/collects/html/html-unit.ss +++ b/collects/html/html-unit.ss @@ -1,142 +1,141 @@ +#lang scheme ;; copyright by Paul Graunke June 2000 AD -(module html-unit mzscheme - (require mzlib/unitsig - mzlib/file - mzlib/list - mzlib/etc - mzlib/include - "html-spec.ss" - "html-sig.ss" - "sgml-reader-sig.ss" - xml/xml-sig) +(require mzlib/file + mzlib/list + mzlib/etc + mzlib/include + "html-spec.ss" + "html-sig.ss" + "sgml-reader-sig.ss" + xml/private/sig) - (provide html@) +(provide html@) - (define html@ - (unit/sig html^ - (import xml^ (sgml : sgml-reader^)) - - ;; Html-content = Html-element | Pc-data | Entity - - (include "html-structs.ss") - (include "case.ss") - - ;; xml->html : Document -> Html - (define (xml->html doc) - (let ([root (document-element doc)]) - (unless (eq? 'html (element-name root)) - (error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root))) - (make-html (element-attributes root) (xml-contents->html (element-content root))))) - - - ;; xml-content->html : (listof Content) -> (listof Html-element) - (define (xml-contents->html contents) - (foldr xml-single-content->html - null - contents)) - - ;; read-xhtml : [Input-port] -> Html - (define read-xhtml (compose xml->html read-xml)) - - ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content) - (define (peel-f toss? to-toss acc0) - (foldr (lambda (x acc) - (if (toss? x) - (append (html-full-content x) acc) - (cons x acc))) - acc0 - to-toss)) - - ;; repackage-html : (listof Html-content) -> Html - (define (repackage-html contents) - (let* ([html (memf html? contents)] - [peeled (peel-f html? contents null)] - [body (memf body? peeled)]) - (make-html (if html - (html-element-attributes (car html)) - null) - (append (filter head? peeled) - (list (make-body (if body - (html-element-attributes (car body)) - null) - (filter (compose not head?) (peel-f body? peeled null)))))))) - - ;; clean-up-pcdata : (listof Content) -> (listof Content) - ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either - ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata - ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata - ;; c) discarded - ;; unknown tags may contain pcdata - ;; the top level may contain pcdata - (define clean-up-pcdata - ;; clean-up-pcdata : (listof Content) -> (listof Content) - (letrec ([clean-up-pcdata - (lambda (content) - (map (lambda (to-fix) - (cond - [(element? to-fix) - (recontent-xml to-fix - (let ([possible (may-contain (element-name to-fix))] - [content (element-content to-fix)]) - (if (or (not possible) (memq 'pcdata possible)) - (clean-up-pcdata content) - (eliminate-pcdata content))))] - [else to-fix])) - content))] - [eliminate-pcdata - ;: (listof Content) -> (listof Content) - (lambda (content) - (let ([non-elements (first-non-elements content)] - [more (memf element? content)]) - (if more - (let* ([el (car more)] - [possible (may-contain (element-name el))]) - (if (or (not possible) (memq 'pcdata possible)) - (cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more))))) - (or (memf element? (cdr more)) null)) - (cons (recontent-xml el (eliminate-pcdata (element-content el))) - (eliminate-pcdata (cdr more))))) - null)))]) - clean-up-pcdata)) - - ;; first-non-elements : (listof Content) -> (listof Content) - (define (first-non-elements content) - (cond - [(null? content) null] - [else (if (element? (car content)) - null - (cons (car content) (first-non-elements (cdr content))))])) - - ;; recontent-xml : Element (listof Content) -> Element - (define (recontent-xml e c) - (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c)) - - ;; implicit-starts : Symbol Symbol -> (U #f Symbol) - (define (implicit-starts parent child) - (or (and (eq? child 'tr) (eq? parent 'table) 'tbody) - (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr))) - - ;; may-contain : Kid-lister - (define may-contain - (sgml:gen-may-contain html-spec)) - - (define may-contain-anything - (sgml:gen-may-contain null)) - - (define use-html-spec (make-parameter #t)) - - ;; read-html-as-xml : [Input-port] -> (listof Content) - (define read-html-as-xml - (case-lambda - [(port) - ((if (use-html-spec) clean-up-pcdata values) - ((sgml:gen-read-sgml (if (use-html-spec) - may-contain - may-contain-anything) - implicit-starts) port))] - [() (read-html-as-xml (current-input-port))])) - - ;; read-html : [Input-port] -> Html - (define read-html - (compose repackage-html xml-contents->html read-html-as-xml))))) +(define-unit html@ + (import xml-structs^ reader^ (prefix sgml: sgml-reader^)) + (export html^) + + ;; Html-content = Html-element | Pc-data | Entity + + (include "html-structs.ss") + (include "case.ss") + + ;; xml->html : Document -> Html + (define (xml->html doc) + (let ([root (document-element doc)]) + (unless (eq? 'html (element-name root)) + (error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root))) + (make-html (element-attributes root) (xml-contents->html (element-content root))))) + + + ;; xml-content->html : (listof Content) -> (listof Html-element) + (define (xml-contents->html contents) + (foldr xml-single-content->html + null + contents)) + + ;; read-xhtml : [Input-port] -> Html + (define read-xhtml (compose xml->html read-xml)) + + ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content) + (define (peel-f toss? to-toss acc0) + (foldr (lambda (x acc) + (if (toss? x) + (append (html-full-content x) acc) + (cons x acc))) + acc0 + to-toss)) + + ;; repackage-html : (listof Html-content) -> Html + (define (repackage-html contents) + (let* ([html (memf html? contents)] + [peeled (peel-f html? contents null)] + [body (memf body? peeled)]) + (make-html (if html + (html-element-attributes (car html)) + null) + (append (filter head? peeled) + (list (make-body (if body + (html-element-attributes (car body)) + null) + (filter (compose not head?) (peel-f body? peeled null)))))))) + + ;; clean-up-pcdata : (listof Content) -> (listof Content) + ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either + ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata + ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata + ;; c) discarded + ;; unknown tags may contain pcdata + ;; the top level may contain pcdata + (define clean-up-pcdata + ;; clean-up-pcdata : (listof Content) -> (listof Content) + (letrec ([clean-up-pcdata + (lambda (content) + (map (lambda (to-fix) + (cond + [(element? to-fix) + (recontent-xml to-fix + (let ([possible (may-contain (element-name to-fix))] + [content (element-content to-fix)]) + (if (or (not possible) (memq 'pcdata possible)) + (clean-up-pcdata content) + (eliminate-pcdata content))))] + [else to-fix])) + content))] + [eliminate-pcdata + ;: (listof Content) -> (listof Content) + (lambda (content) + (let ([non-elements (first-non-elements content)] + [more (memf element? content)]) + (if more + (let* ([el (car more)] + [possible (may-contain (element-name el))]) + (if (or (not possible) (memq 'pcdata possible)) + (cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more))))) + (or (memf element? (cdr more)) null)) + (cons (recontent-xml el (eliminate-pcdata (element-content el))) + (eliminate-pcdata (cdr more))))) + null)))]) + clean-up-pcdata)) + + ;; first-non-elements : (listof Content) -> (listof Content) + (define (first-non-elements content) + (cond + [(null? content) null] + [else (if (element? (car content)) + null + (cons (car content) (first-non-elements (cdr content))))])) + + ;; recontent-xml : Element (listof Content) -> Element + (define (recontent-xml e c) + (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c)) + + ;; implicit-starts : Symbol Symbol -> (U #f Symbol) + (define (implicit-starts parent child) + (or (and (eq? child 'tr) (eq? parent 'table) 'tbody) + (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr))) + + ;; may-contain : Kid-lister + (define may-contain + (sgml:gen-may-contain html-spec)) + + (define may-contain-anything + (sgml:gen-may-contain null)) + + (define use-html-spec (make-parameter #t)) + + ;; read-html-as-xml : [Input-port] -> (listof Content) + (define read-html-as-xml + (case-lambda + [(port) + ((if (use-html-spec) clean-up-pcdata values) + ((sgml:gen-read-sgml (if (use-html-spec) + may-contain + may-contain-anything) + implicit-starts) port))] + [() (read-html-as-xml (current-input-port))])) + + ;; read-html : [Input-port] -> Html + (define read-html + (compose repackage-html xml-contents->html read-html-as-xml))) diff --git a/collects/html/html.scrbl b/collects/html/html.scrbl index 9b7564591b..6dc7c7b514 100644 --- a/collects/html/html.scrbl +++ b/collects/html/html.scrbl @@ -78,7 +78,7 @@ Reads HTML from a port, producing an @xexpr compatible with the (code:comment #, @t{Pulls out the pcdata strings from an-html-element.}) (define (extract-pcdata-from-element an-html-element) (match an-html-element - [(struct h:html-full (content)) + [(struct h:html-full (attributes content)) (apply append (map extract-pcdata content))] [(struct h:html-element (attributes)) diff --git a/collects/html/html.ss b/collects/html/html.ss index de547502d4..381e05f8f7 100644 --- a/collects/html/html.ss +++ b/collects/html/html.ss @@ -1,30 +1,22 @@ +#lang scheme ;; copyright by Paul Graunke June 2000 AD -(module html mzscheme - (require mzlib/unitsig - "html-sig.ss" - "html-unit.ss" - "sgml-reader-sig.ss" - "sgml-reader-unit.ss" - xml/xml - xml/xml-sig - xml/private/sig - xml/xml-unit) +(require "html-mod.ss" "html-sig.ss" "sgml-reader.ss") - ;; To get read-comments from sgml-reader, we have to - ;; avoid the read-comments from XML, so we rename it - ;; to read-html-comments. +#;(require "html-sig.ss" + "html-unit.ss" + "sgml-reader-sig.ss" + "sgml-reader-unit.ss" + xml/private/structures + xml/private/reader + xml/private/sig) - (define-values/invoke-unit/sig - ((open html^) read-html-comments) - (compound-unit/sig - (import [x : xml^]) - (link - [s : sgml-reader^ (sgml-reader@ (x : xml-structs^))] - [h : html^ (html@ x s)]) - (export (open h) (var (s read-comments) read-html-comments))) - #f - xml^) +#;(define-compound-unit/infer the-html@ + (import) + (export html^ sgml-reader^) + (link html@ sgml-reader@ xml-structs@ reader@)) - (provide-signature-elements html^) - (provide read-html-comments)) +#;(define-values/invoke-unit/infer the-html@) + +(provide-signature-elements html^) +(provide read-html-comments) diff --git a/collects/html/sgml-reader-sig.ss b/collects/html/sgml-reader-sig.ss index 9ac150c2ac..3454b2ea4e 100644 --- a/collects/html/sgml-reader-sig.ss +++ b/collects/html/sgml-reader-sig.ss @@ -1,8 +1,6 @@ ;; copyright by Paul Graunke June 2000 AD +#lang scheme -(module sgml-reader-sig mzscheme - (require mzlib/unitsig) +(define-signature sgml-reader^ (read-html-comments trim-whitespace gen-may-contain gen-read-sgml)) - (define-signature sgml-reader^ (read-comments trim-whitespace gen-may-contain gen-read-sgml)) - - (provide sgml-reader^)) +(provide sgml-reader^) diff --git a/collects/html/sgml-reader-unit.ss b/collects/html/sgml-reader-unit.ss index 30be92f0b7..ee8403d257 100644 --- a/collects/html/sgml-reader-unit.ss +++ b/collects/html/sgml-reader-unit.ss @@ -1,296 +1,294 @@ ;; copyright by Paul Graunke June 2000 AD ;; warning - this was copied from the XML collection. ;; It needs to be abstracted back in. +#lang scheme +(require mzlib/list + mzlib/string + "sgml-reader-sig.ss" + xml/private/sig) -(module sgml-reader-unit mzscheme - (require mzlib/unitsig - mzlib/list - mzlib/string - "sgml-reader-sig.ss" - xml/private/sig) +(provide sgml-reader@) - (provide sgml-reader@) - - (define sgml-reader@ - (unit/sig sgml-reader^ - (import xml-structs^) - - ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) - (define-struct (start-tag source) (name attrs)) - - ;; End-tag ::= (make-end-tag Location Location Symbol) - (define-struct (end-tag source) (name)) - - ;; Token ::= Contents | Start-tag | End-tag | Eof - - (define read-comments (make-parameter #f)) - (define trim-whitespace (make-parameter #f)) - - ;; Kid-lister : (Symbol -> (U (listof Symbol) #f)) - - ;; gen-may-contain : Spec -> Kid-lister - (define (gen-may-contain spec) - (let ([table (make-hash-table)]) - (for-each (lambda (def) - (let ([rhs (cdr def)]) - (for-each (lambda (name) (hash-table-put! table name rhs)) - (car def)))) - spec) - (lambda (name) - (hash-table-get table name (lambda () #f))))) - - ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content) - (define (gen-read-sgml may-contain auto-insert) - (case-lambda - [(in) (read-from-port may-contain auto-insert in)] - [() (read-from-port may-contain auto-insert (current-input-port))])) - - ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content) - (define (read-from-port may-contain auto-insert in) - (let loop ([tokens (let read-tokens () - (let ([tok (lex in)]) - (cond - [(eof-object? tok) null] - [else (cons tok (read-tokens))])))]) - (cond - [(null? tokens) null] - [else - (let ([tok (car tokens)] [rest-tokens (cdr tokens)]) - (cond - [(start-tag? tok) - (let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)]) - (cons el (loop more-tokens)))] - [(end-tag? tok) (loop rest-tokens)] - [else (let ([rest-contents (loop rest-tokens)]) - (expand-content tok rest-contents))]))]))) - - ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token) - ;; Note: How elements nest depends on their content model. - ;; If a kind of element can't contain anything, then its start tags are implicitly ended, and - ;; end tags are implicitly started. - ;; Unknown elements can contain anything and can go inside anything. - ;; Otherwise, only the subelements listed in the content model can go inside an element. - ;; more here - may-contain shouldn't be used to decide if an element is known or not. - ;; The edgar dtd puts tags in may-contain's range that aren't in its domain. - ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the - ;; tag nesting depth. However, this only should be a problem when the tag is there, - ;; but far back. That shouldn't happen often. I'm guessing n will be about 3. - (define (read-element start-tag context may-contain auto-insert tokens) - (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens]) - (let* ([start-name (start-tag-name start-tag)] - [ok-kids (may-contain start-name)]) - (let-values ([(content remaining) - (cond - [(null? ok-kids) (values null tokens)] - [else - ;; read-content : (listof Token) -> (listof Content) (listof Token) - (let read-content ([tokens tokens]) - (cond - [(null? tokens) (values null tokens)] - [else - (let ([tok (car tokens)] [next-tokens (cdr tokens)]) - (cond - [(start-tag? tok) - (let* ([name (start-tag-name tok)] - [auto-start (auto-insert start-name name)]) - (if auto-start - (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens)) - (if (and ok-kids - (not (memq name ok-kids)) - (may-contain name)) - (values null tokens) - (let*-values ([(element post-element) - (read-el tok (cons name context) next-tokens)] - [(more-contents left-overs) (read-content post-element)]) - (values (cons element more-contents) left-overs)))))] - [(end-tag? tok) - (let ([name (end-tag-name tok)]) - (if (eq? name start-name) - (values null next-tokens) - (if (memq name context) - (values null tokens) - (read-content next-tokens))))] - [else ;; content - (let-values ([(more-contents left-overs) (read-content next-tokens)]) - (values - (expand-content tok more-contents) - left-overs))]))]))])]) - (values (make-element (source-start start-tag) - (source-stop start-tag) - start-name - (start-tag-attrs start-tag) - content) - remaining))))) - - ;; expand-content : Content (listof Content) -> (listof Content) - (define (expand-content x lst) - (cond - [(entity? x) (cons (expand-entity x) lst)] - [(comment? x) (if (read-comments) - (cons x lst) - lst)] - [else (cons x lst)])) - - ;; expand-entity : Entity -> (U Entity Pcdata) - ;; more here - allow expansion of user defined entities - (define (expand-entity x) - (let ([expanded (default-entity-table (entity-text x))]) - (if expanded - (make-pcdata (source-start x) (source-stop x) expanded) - x))) - - ;; default-entity-table : Symbol -> (U #f String) - (define (default-entity-table name) - (case name - [(amp) "&"] - [(lt) "<"] - [(gt) ">"] - [(quot) "\""] - [(apos) "'"] - [else #f])) - - ;; lex : Input-port -> Token - (define (lex in) - (when (trim-whitespace) - (skip-space in)) - (let ([c (peek-char in)]) - (cond - [(eof-object? c) c] - [(eq? c #\&) (lex-entity in)] - [(eq? c #\<) (lex-tag-cdata-pi-comment in)] - [else (lex-pcdata in)]))) - - ;; lex-entity : Input-port -> Token - ;; This might not return an entity if it doesn't look like one afterall. - (define (lex-entity in) - (let ([start (file-position in)]) - (read-char in) - (case (peek-char in) - ;; more here - read while it's numeric (or hex) not until #\; - [(#\#) - (read-char in) - (let* ([hex? (if (equal? #\x (peek-char in)) - (and (read-char in) #t) - #f)] - [str (read-until #\; in)] - [n (cond - [hex? - (string->number str 16)] - [else (string->number str)])]) - (if (number? n) - (make-entity start (file-position in) n) - (make-pcdata start (file-position in) (string-append "&#" str))))] - [else - (let ([name (lex-name/case-sensitive in)] - [c (peek-char in)]) - (if (eq? c #\;) - (begin (read-char in) (make-entity start (file-position in) name)) - (make-pcdata start (file-position in) (format "&~a" name))))]))) - - ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment - (define (lex-tag-cdata-pi-comment in) - (let ([start (file-position in)]) - (read-char in) - (case (peek-char in) - [(#\!) - (read-char in) - (case (peek-char in) - [(#\-) (read-char in) - (let ([c (read-char in)]) - (cond - [(eq? c #\-) - (let ([data (lex-comment-contents in)]) - (make-comment data))] - [else (make-pcdata start (file-position in) (format " or whatever else is there - (make-end-tag start (file-position in) name))] - [else - (let ([name (lex-name in)] - [attrs (lex-attributes in)]) - (skip-space in) - (case (read-char in) - [(#\/) - (read-char in) ;; skip #\> or something - (make-element start (file-position in) name attrs null)] - [else (make-start-tag start (file-position in) name attrs)]))]))) - - - ;; lex-attributes : Input-port -> (listof Attribute) - (define (lex-attributes in) - (sort (let loop () - (skip-space in) - (cond [(name-start? (peek-char in)) - (cons (lex-attribute in) (loop))] - [else null])) - (lambda (a b) - (stringstring (attribute-name a)) - (symbol->string (attribute-name b)))))) - - ;; lex-attribute : Input-port -> Attribute - ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax - (define (lex-attribute in) - (let ([start (file-position in)] - [name (lex-name in)]) - (skip-space in) - (cond - [(eq? (peek-char in) #\=) - (read-char in) - (skip-space in) - (let* ([delimiter (read-char in)] - [value (list->string - (case delimiter - [(#\' #\") - (let read-more () - (let ([c (read-char in)]) - (cond - [(or (eq? c delimiter) (eof-object? c)) null] - [else (cons c (read-more))])))] - [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))]) - (make-attribute start (file-position in) name value))] - [else (make-attribute start (file-position in) name (symbol->string name))]))) - - ;; skip-space : Input-port -> Void - ;; deviation - should sometimes insist on at least one space - (define (skip-space in) - (let loop () - (let ([c (peek-char in)]) - (when (and (not (eof-object? c)) (char-whitespace? c)) - (read-char in) - (loop))))) - - ;; lex-pcdata : Input-port -> Pcdata - ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec - (define (lex-pcdata in) - (let ([start (file-position in)]) - ;; The following regexp match must use bytes, not chars, because - ;; `in' might not be a well-formed UTF-8 sequence. If it isn't, - ;; and it goes wrong with the first byte sequence, then a char-based - ;; pattern would match 0 characters. Meanwhile, the caller of this function - ;; expects characters to be read. - (let ([s (regexp-match #rx#"^[^&<]*" in)]) - (make-pcdata start - (file-position in) - (bytes->string/utf-8 - (if (trim-whitespace) - (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"") - (car s)) - #\?))))) -#| +(define-unit sgml-reader@ + (import xml-structs^) + (export sgml-reader^) + + ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) + (define-struct (start-tag source) (name attrs)) + + ;; End-tag ::= (make-end-tag Location Location Symbol) + (define-struct (end-tag source) (name)) + + ;; Token ::= Contents | Start-tag | End-tag | Eof + + (define read-html-comments (make-parameter #f)) + (define trim-whitespace (make-parameter #f)) + + ;; Kid-lister : (Symbol -> (U (listof Symbol) #f)) + + ;; gen-may-contain : Spec -> Kid-lister + (define (gen-may-contain spec) + (let ([table (make-hash)]) + (for-each (lambda (def) + (let ([rhs (cdr def)]) + (for-each (lambda (name) (hash-set! table name rhs)) + (car def)))) + spec) + (lambda (name) + (hash-ref table name (lambda () #f))))) + + ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content) + (define (gen-read-sgml may-contain auto-insert) + (case-lambda + [(in) (read-from-port may-contain auto-insert in)] + [() (read-from-port may-contain auto-insert (current-input-port))])) + + ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content) + (define (read-from-port may-contain auto-insert in) + (let loop ([tokens (let read-tokens () + (let ([tok (lex in)]) + (cond + [(eof-object? tok) null] + [else (cons tok (read-tokens))])))]) + (cond + [(null? tokens) null] + [else + (let ([tok (car tokens)] [rest-tokens (cdr tokens)]) + (cond + [(start-tag? tok) + (let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)]) + (cons el (loop more-tokens)))] + [(end-tag? tok) (loop rest-tokens)] + [else (let ([rest-contents (loop rest-tokens)]) + (expand-content tok rest-contents))]))]))) + + ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token) + ;; Note: How elements nest depends on their content model. + ;; If a kind of element can't contain anything, then its start tags are implicitly ended, and + ;; end tags are implicitly started. + ;; Unknown elements can contain anything and can go inside anything. + ;; Otherwise, only the subelements listed in the content model can go inside an element. + ;; more here - may-contain shouldn't be used to decide if an element is known or not. + ;; The edgar dtd puts tags in may-contain's range that aren't in its domain. + ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the + ;; tag nesting depth. However, this only should be a problem when the tag is there, + ;; but far back. That shouldn't happen often. I'm guessing n will be about 3. + (define (read-element start-tag context may-contain auto-insert tokens) + (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens]) + (let* ([start-name (start-tag-name start-tag)] + [ok-kids (may-contain start-name)]) + (let-values ([(content remaining) + (cond + [(null? ok-kids) (values null tokens)] + [else + ;; read-content : (listof Token) -> (listof Content) (listof Token) + (let read-content ([tokens tokens]) + (cond + [(null? tokens) (values null tokens)] + [else + (let ([tok (car tokens)] [next-tokens (cdr tokens)]) + (cond + [(start-tag? tok) + (let* ([name (start-tag-name tok)] + [auto-start (auto-insert start-name name)]) + (if auto-start + (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens)) + (if (and ok-kids + (not (memq name ok-kids)) + (may-contain name)) + (values null tokens) + (let*-values ([(element post-element) + (read-el tok (cons name context) next-tokens)] + [(more-contents left-overs) (read-content post-element)]) + (values (cons element more-contents) left-overs)))))] + [(end-tag? tok) + (let ([name (end-tag-name tok)]) + (if (eq? name start-name) + (values null next-tokens) + (if (memq name context) + (values null tokens) + (read-content next-tokens))))] + [else ;; content + (let-values ([(more-contents left-overs) (read-content next-tokens)]) + (values + (expand-content tok more-contents) + left-overs))]))]))])]) + (values (make-element (source-start start-tag) + (source-stop start-tag) + start-name + (start-tag-attrs start-tag) + content) + remaining))))) + + ;; expand-content : Content (listof Content) -> (listof Content) + (define (expand-content x lst) + (cond + [(entity? x) (cons (expand-entity x) lst)] + [(comment? x) (if (read-html-comments) + (cons x lst) + lst)] + [else (cons x lst)])) + + ;; expand-entity : Entity -> (U Entity Pcdata) + ;; more here - allow expansion of user defined entities + (define (expand-entity x) + (let ([expanded (default-entity-table (entity-text x))]) + (if expanded + (make-pcdata (source-start x) (source-stop x) expanded) + x))) + + ;; default-entity-table : Symbol -> (U #f String) + (define (default-entity-table name) + (case name + [(amp) "&"] + [(lt) "<"] + [(gt) ">"] + [(quot) "\""] + [(apos) "'"] + [else #f])) + + ;; lex : Input-port -> Token + (define (lex in) + (when (trim-whitespace) + (skip-space in)) + (let ([c (peek-char in)]) + (cond + [(eof-object? c) c] + [(eq? c #\&) (lex-entity in)] + [(eq? c #\<) (lex-tag-cdata-pi-comment in)] + [else (lex-pcdata in)]))) + + ;; lex-entity : Input-port -> Token + ;; This might not return an entity if it doesn't look like one afterall. + (define (lex-entity in) + (let ([start (file-position in)]) + (read-char in) + (case (peek-char in) + ;; more here - read while it's numeric (or hex) not until #\; + [(#\#) + (read-char in) + (let* ([hex? (if (equal? #\x (peek-char in)) + (and (read-char in) #t) + #f)] + [str (read-until #\; in)] + [n (cond + [hex? + (string->number str 16)] + [else (string->number str)])]) + (if (number? n) + (make-entity start (file-position in) n) + (make-pcdata start (file-position in) (string-append "&#" str))))] + [else + (let ([name (lex-name/case-sensitive in)] + [c (peek-char in)]) + (if (eq? c #\;) + (begin (read-char in) (make-entity start (file-position in) name)) + (make-pcdata start (file-position in) (format "&~a" name))))]))) + + ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment + (define (lex-tag-cdata-pi-comment in) + (let ([start (file-position in)]) + (read-char in) + (case (peek-char in) + [(#\!) + (read-char in) + (case (peek-char in) + [(#\-) (read-char in) + (let ([c (read-char in)]) + (cond + [(eq? c #\-) + (let ([data (lex-comment-contents in)]) + (make-comment data))] + [else (make-pcdata start (file-position in) (format " or whatever else is there + (make-end-tag start (file-position in) name))] + [else + (let ([name (lex-name in)] + [attrs (lex-attributes in)]) + (skip-space in) + (case (read-char in) + [(#\/) + (read-char in) ;; skip #\> or something + (make-element start (file-position in) name attrs null)] + [else (make-start-tag start (file-position in) name attrs)]))]))) + + + ;; lex-attributes : Input-port -> (listof Attribute) + (define (lex-attributes in) + (sort (let loop () + (skip-space in) + (cond [(name-start? (peek-char in)) + (cons (lex-attribute in) (loop))] + [else null])) + (lambda (a b) + (stringstring (attribute-name a)) + (symbol->string (attribute-name b)))))) + + ;; lex-attribute : Input-port -> Attribute + ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax + (define (lex-attribute in) + (let ([start (file-position in)] + [name (lex-name in)]) + (skip-space in) + (cond + [(eq? (peek-char in) #\=) + (read-char in) + (skip-space in) + (let* ([delimiter (read-char in)] + [value (list->string + (case delimiter + [(#\' #\") + (let read-more () + (let ([c (read-char in)]) + (cond + [(or (eq? c delimiter) (eof-object? c)) null] + [else (cons c (read-more))])))] + [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))]) + (make-attribute start (file-position in) name value))] + [else (make-attribute start (file-position in) name (symbol->string name))]))) + + ;; skip-space : Input-port -> Void + ;; deviation - should sometimes insist on at least one space + (define (skip-space in) + (let loop () + (let ([c (peek-char in)]) + (when (and (not (eof-object? c)) (char-whitespace? c)) + (read-char in) + (loop))))) + + ;; lex-pcdata : Input-port -> Pcdata + ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec + (define (lex-pcdata in) + (let ([start (file-position in)]) + ;; The following regexp match must use bytes, not chars, because + ;; `in' might not be a well-formed UTF-8 sequence. If it isn't, + ;; and it goes wrong with the first byte sequence, then a char-based + ;; pattern would match 0 characters. Meanwhile, the caller of this function + ;; expects characters to be read. + (let ([s (regexp-match #rx#"^[^&<]*" in)]) + (make-pcdata start + (file-position in) + (bytes->string/utf-8 + (if (trim-whitespace) + (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"") + (car s)) + #\?))))) + #| ;; Original slow version: (define (lex-pcdata in) (let ([start (file-position in)] @@ -311,22 +309,22 @@ (list->string data)))) |# - - ;; lex-name : Input-port -> Symbol - (define (lex-name in) - (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) - (string->symbol - ;; Common case: string is already lowercased - (if (regexp-match-positions #rx"[A-Z]" s) - (begin - (string-lowercase! s) - s) - s)))) - ;; lex-name/case-sensitive : Input-port -> Symbol - (define (lex-name/case-sensitive in) - (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) - (string->symbol s))) -#| + + ;; lex-name : Input-port -> Symbol + (define (lex-name in) + (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) + (string->symbol + ;; Common case: string is already lowercased + (if (regexp-match-positions #rx"[A-Z]" s) + (begin + (string-lowercase! s) + s) + s)))) + ;; lex-name/case-sensitive : Input-port -> Symbol + (define (lex-name/case-sensitive in) + (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) + (string->symbol s))) + #| (define (lex-name in) (string->symbol (list->string @@ -336,101 +334,100 @@ (cons (char-downcase (read-char in)) (lex-rest))] [else null]))))) |# - - - ;; skip-dtd : Input-port -> Void - (define (skip-dtd in) - (let skip () - (let ([c (read-char in)]) - (if (eof-object? c) - (void) - (case c - [(#\') (read-until #\' in) (skip)] - [(#\") (read-until #\" in) (skip)] - [(#\<) - (case (read-char in) - [(#\!) (case (read-char in) - [(#\-) (read-char in) (lex-comment-contents in) (skip)] - [else (skip) (skip)])] - [(#\?) (lex-pi-data in) (skip)] - [else (skip) (skip)])] - [(#\>) (void)] - [else (skip)]))))) - - ;; name-start? : TST -> Bool - (define (name-start? ch) - (and (char? ch) (char-name-start? ch))) - - ;; char-name-start? : Char -> Bool - (define (char-name-start? ch) - (or (char-alphabetic? ch) - (eq? ch #\_) - (eq? ch #\:))) - - ;; name-char? : TST -> Bool - (define (name-char? ch) - (and (char? ch) - (or (char-name-start? ch) - (char-numeric? ch) - (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database - (eq? ch #\.) - (eq? ch #\-)))) - - ;; read-up-to : (Char -> Bool) Input-port -> (listof Char) - ;; abstract this with read-until - (define (read-up-to p? in) - (let loop () - (let ([c (peek-char in)]) - (cond - [(or (eof-object? c) (p? c)) null] - [else (cons (read-char in) (loop))])))) - - ;; read-until : Char Input-port -> String - ;; discards the stop character, too - (define (read-until char in) - (list->string - (let read-more () - (let ([c (read-char in)]) - (cond - [(or (eof-object? c) (eq? c char)) null] - [else (cons c (read-more))]))))) - - ;; gen-read-until-string : String -> Input-port -> String - ;; uses Knuth-Morris-Pratt from - ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 - ;; discards stop from input - (define (gen-read-until-string stop) - (let* ([len (string-length stop)] - [prefix (make-vector len 0)] - [fall-back - (lambda (k c) - (let ([k (let loop ([k k]) - (cond - [(and (> k 0) (not (eq? (string-ref stop k) c))) - (loop (vector-ref prefix (sub1 k)))] - [else k]))]) - (if (eq? (string-ref stop k) c) - (add1 k) - k)))]) - (let init ([k 0] [q 1]) - (when (< q len) - (let ([k (fall-back k (string-ref stop q))]) - (vector-set! prefix q k) - (init k (add1 q))))) - ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop - (lambda (in) - (list->string - (let/ec out - (let loop ([matched 0] [out out]) - (let* ([c (read-char in)] - [matched (fall-back matched c)]) - (cond - [(or (eof-object? c) (= matched len)) (out null)] - [(zero? matched) (cons c (let/ec out (loop matched out)))] - [else (cons c (loop matched out))])))))))) - - ;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore. - (define lex-comment-contents (gen-read-until-string "-->")) - (define lex-pi-data (gen-read-until-string "?>")) - (define lex-cdata-contents (gen-read-until-string "]]>"))))) - + + + ;; skip-dtd : Input-port -> Void + (define (skip-dtd in) + (let skip () + (let ([c (read-char in)]) + (if (eof-object? c) + (void) + (case c + [(#\') (read-until #\' in) (skip)] + [(#\") (read-until #\" in) (skip)] + [(#\<) + (case (read-char in) + [(#\!) (case (read-char in) + [(#\-) (read-char in) (lex-comment-contents in) (skip)] + [else (skip) (skip)])] + [(#\?) (lex-pi-data in) (skip)] + [else (skip) (skip)])] + [(#\>) (void)] + [else (skip)]))))) + + ;; name-start? : TST -> Bool + (define (name-start? ch) + (and (char? ch) (char-name-start? ch))) + + ;; char-name-start? : Char -> Bool + (define (char-name-start? ch) + (or (char-alphabetic? ch) + (eq? ch #\_) + (eq? ch #\:))) + + ;; name-char? : TST -> Bool + (define (name-char? ch) + (and (char? ch) + (or (char-name-start? ch) + (char-numeric? ch) + (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database + (eq? ch #\.) + (eq? ch #\-)))) + + ;; read-up-to : (Char -> Bool) Input-port -> (listof Char) + ;; abstract this with read-until + (define (read-up-to p? in) + (let loop () + (let ([c (peek-char in)]) + (cond + [(or (eof-object? c) (p? c)) null] + [else (cons (read-char in) (loop))])))) + + ;; read-until : Char Input-port -> String + ;; discards the stop character, too + (define (read-until char in) + (list->string + (let read-more () + (let ([c (read-char in)]) + (cond + [(or (eof-object? c) (eq? c char)) null] + [else (cons c (read-more))]))))) + + ;; gen-read-until-string : String -> Input-port -> String + ;; uses Knuth-Morris-Pratt from + ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 + ;; discards stop from input + (define (gen-read-until-string stop) + (let* ([len (string-length stop)] + [prefix (make-vector len 0)] + [fall-back + (lambda (k c) + (let ([k (let loop ([k k]) + (cond + [(and (> k 0) (not (eq? (string-ref stop k) c))) + (loop (vector-ref prefix (sub1 k)))] + [else k]))]) + (if (eq? (string-ref stop k) c) + (add1 k) + k)))]) + (let init ([k 0] [q 1]) + (when (< q len) + (let ([k (fall-back k (string-ref stop q))]) + (vector-set! prefix q k) + (init k (add1 q))))) + ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop + (lambda (in) + (list->string + (let/ec out + (let loop ([matched 0] [out out]) + (let* ([c (read-char in)] + [matched (fall-back matched c)]) + (cond + [(or (eof-object? c) (= matched len)) (out null)] + [(zero? matched) (cons c (let/ec out (loop matched out)))] + [else (cons c (loop matched out))])))))))) + + ;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore. + (define lex-comment-contents (gen-read-until-string "-->")) + (define lex-pi-data (gen-read-until-string "?>")) + (define lex-cdata-contents (gen-read-until-string "]]>"))) diff --git a/collects/html/sgml-reader.ss b/collects/html/sgml-reader.ss new file mode 100644 index 0000000000..4dfe8a95be --- /dev/null +++ b/collects/html/sgml-reader.ss @@ -0,0 +1,429 @@ +;; copyright by Paul Graunke June 2000 AD +;; warning - this was copied from the XML collection. +;; It needs to be abstracted back in. +#lang scheme +(require mzlib/list + mzlib/string + "sgml-reader-sig.ss" + xml) + +(provide-signature-elements sgml-reader^) + + ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) + (define-struct (start-tag source) (name attrs)) + + ;; End-tag ::= (make-end-tag Location Location Symbol) + (define-struct (end-tag source) (name)) + + ;; Token ::= Contents | Start-tag | End-tag | Eof + + (define read-html-comments (make-parameter #f)) + (define trim-whitespace (make-parameter #f)) + + ;; Kid-lister : (Symbol -> (U (listof Symbol) #f)) + + ;; gen-may-contain : Spec -> Kid-lister + (define (gen-may-contain spec) + (let ([table (make-hash)]) + (for-each (lambda (def) + (let ([rhs (cdr def)]) + (for-each (lambda (name) (hash-set! table name rhs)) + (car def)))) + spec) + (lambda (name) + (hash-ref table name (lambda () #f))))) + + ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content) + (define (gen-read-sgml may-contain auto-insert) + (case-lambda + [(in) (read-from-port may-contain auto-insert in)] + [() (read-from-port may-contain auto-insert (current-input-port))])) + + ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content) + (define (read-from-port may-contain auto-insert in) + (let loop ([tokens (let read-tokens () + (let ([tok (lex in)]) + (cond + [(eof-object? tok) null] + [else (cons tok (read-tokens))])))]) + (cond + [(null? tokens) null] + [else + (let ([tok (car tokens)] [rest-tokens (cdr tokens)]) + (cond + [(start-tag? tok) + (let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)]) + (cons el (loop more-tokens)))] + [(end-tag? tok) (loop rest-tokens)] + [else (let ([rest-contents (loop rest-tokens)]) + (expand-content tok rest-contents))]))]))) + + ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token) + ;; Note: How elements nest depends on their content model. + ;; If a kind of element can't contain anything, then its start tags are implicitly ended, and + ;; end tags are implicitly started. + ;; Unknown elements can contain anything and can go inside anything. + ;; Otherwise, only the subelements listed in the content model can go inside an element. + ;; more here - may-contain shouldn't be used to decide if an element is known or not. + ;; The edgar dtd puts tags in may-contain's range that aren't in its domain. + ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the + ;; tag nesting depth. However, this only should be a problem when the tag is there, + ;; but far back. That shouldn't happen often. I'm guessing n will be about 3. + (define (read-element start-tag context may-contain auto-insert tokens) + (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens]) + (let* ([start-name (start-tag-name start-tag)] + [ok-kids (may-contain start-name)]) + (let-values ([(content remaining) + (cond + [(null? ok-kids) (values null tokens)] + [else + ;; read-content : (listof Token) -> (listof Content) (listof Token) + (let read-content ([tokens tokens]) + (cond + [(null? tokens) (values null tokens)] + [else + (let ([tok (car tokens)] [next-tokens (cdr tokens)]) + (cond + [(start-tag? tok) + (let* ([name (start-tag-name tok)] + [auto-start (auto-insert start-name name)]) + (if auto-start + (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens)) + (if (and ok-kids + (not (memq name ok-kids)) + (may-contain name)) + (values null tokens) + (let*-values ([(element post-element) + (read-el tok (cons name context) next-tokens)] + [(more-contents left-overs) (read-content post-element)]) + (values (cons element more-contents) left-overs)))))] + [(end-tag? tok) + (let ([name (end-tag-name tok)]) + (if (eq? name start-name) + (values null next-tokens) + (if (memq name context) + (values null tokens) + (read-content next-tokens))))] + [else ;; content + (let-values ([(more-contents left-overs) (read-content next-tokens)]) + (values + (expand-content tok more-contents) + left-overs))]))]))])]) + (values (make-element (source-start start-tag) + (source-stop start-tag) + start-name + (start-tag-attrs start-tag) + content) + remaining))))) + + ;; expand-content : Content (listof Content) -> (listof Content) + (define (expand-content x lst) + (cond + [(entity? x) (cons (expand-entity x) lst)] + [(comment? x) (if (read-html-comments) + (cons x lst) + lst)] + [else (cons x lst)])) + + ;; expand-entity : Entity -> (U Entity Pcdata) + ;; more here - allow expansion of user defined entities + (define (expand-entity x) + (let ([expanded (default-entity-table (entity-text x))]) + (if expanded + (make-pcdata (source-start x) (source-stop x) expanded) + x))) + + ;; default-entity-table : Symbol -> (U #f String) + (define (default-entity-table name) + (case name + [(amp) "&"] + [(lt) "<"] + [(gt) ">"] + [(quot) "\""] + [(apos) "'"] + [else #f])) + + ;; lex : Input-port -> Token + (define (lex in) + (when (trim-whitespace) + (skip-space in)) + (let ([c (peek-char in)]) + (cond + [(eof-object? c) c] + [(eq? c #\&) (lex-entity in)] + [(eq? c #\<) (lex-tag-cdata-pi-comment in)] + [else (lex-pcdata in)]))) + + ;; lex-entity : Input-port -> Token + ;; This might not return an entity if it doesn't look like one afterall. + (define (lex-entity in) + (let ([start (file-position in)]) + (read-char in) + (case (peek-char in) + ;; more here - read while it's numeric (or hex) not until #\; + [(#\#) + (read-char in) + (let* ([hex? (if (equal? #\x (peek-char in)) + (and (read-char in) #t) + #f)] + [str (read-until #\; in)] + [n (cond + [hex? + (string->number str 16)] + [else (string->number str)])]) + (if (number? n) + (make-entity start (file-position in) n) + (make-pcdata start (file-position in) (string-append "&#" str))))] + [else + (let ([name (lex-name/case-sensitive in)] + [c (peek-char in)]) + (if (eq? c #\;) + (begin (read-char in) (make-entity start (file-position in) name)) + (make-pcdata start (file-position in) (format "&~a" name))))]))) + + ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment + (define (lex-tag-cdata-pi-comment in) + (let ([start (file-position in)]) + (read-char in) + (case (peek-char in) + [(#\!) + (read-char in) + (case (peek-char in) + [(#\-) (read-char in) + (let ([c (read-char in)]) + (cond + [(eq? c #\-) + (let ([data (lex-comment-contents in)]) + (make-comment data))] + [else (make-pcdata start (file-position in) (format " or whatever else is there + (make-end-tag start (file-position in) name))] + [else + (let ([name (lex-name in)] + [attrs (lex-attributes in)]) + (skip-space in) + (case (read-char in) + [(#\/) + (read-char in) ;; skip #\> or something + (make-element start (file-position in) name attrs null)] + [else (make-start-tag start (file-position in) name attrs)]))]))) + + + ;; lex-attributes : Input-port -> (listof Attribute) + (define (lex-attributes in) + (sort (let loop () + (skip-space in) + (cond [(name-start? (peek-char in)) + (cons (lex-attribute in) (loop))] + [else null])) + (lambda (a b) + (stringstring (attribute-name a)) + (symbol->string (attribute-name b)))))) + + ;; lex-attribute : Input-port -> Attribute + ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax + (define (lex-attribute in) + (let ([start (file-position in)] + [name (lex-name in)]) + (skip-space in) + (cond + [(eq? (peek-char in) #\=) + (read-char in) + (skip-space in) + (let* ([delimiter (read-char in)] + [value (list->string + (case delimiter + [(#\' #\") + (let read-more () + (let ([c (read-char in)]) + (cond + [(or (eq? c delimiter) (eof-object? c)) null] + [else (cons c (read-more))])))] + [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))]) + (make-attribute start (file-position in) name value))] + [else (make-attribute start (file-position in) name (symbol->string name))]))) + + ;; skip-space : Input-port -> Void + ;; deviation - should sometimes insist on at least one space + (define (skip-space in) + (let loop () + (let ([c (peek-char in)]) + (when (and (not (eof-object? c)) (char-whitespace? c)) + (read-char in) + (loop))))) + + ;; lex-pcdata : Input-port -> Pcdata + ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec + (define (lex-pcdata in) + (let ([start (file-position in)]) + ;; The following regexp match must use bytes, not chars, because + ;; `in' might not be a well-formed UTF-8 sequence. If it isn't, + ;; and it goes wrong with the first byte sequence, then a char-based + ;; pattern would match 0 characters. Meanwhile, the caller of this function + ;; expects characters to be read. + (let ([s (regexp-match #rx#"^[^&<]*" in)]) + (make-pcdata start + (file-position in) + (bytes->string/utf-8 + (if (trim-whitespace) + (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"") + (car s)) + #\?))))) + #| + ;; Original slow version: + (define (lex-pcdata in) + (let ([start (file-position in)] + [data (let loop ([c (read-char in)]) + (let ([next (peek-char in)]) + (cond + [(or (eof-object? next) (eq? next #\&) (eq? next #\<)) + (list c)] + [(and (char-whitespace? next) (trim-whitespace)) + (skip-space in) + (let ([lst (loop #\space)]) + (cond + [(null? (cdr lst)) (list c)] + [else (cons c lst)]))] + [else (cons c (loop (read-char in)))])))]) + (make-pcdata start + (file-position in) + (list->string data)))) + |# + + + ;; lex-name : Input-port -> Symbol + (define (lex-name in) + (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) + (string->symbol + ;; Common case: string is already lowercased + (if (regexp-match-positions #rx"[A-Z]" s) + (begin + (string-lowercase! s) + s) + s)))) + ;; lex-name/case-sensitive : Input-port -> Symbol + (define (lex-name/case-sensitive in) + (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) + (string->symbol s))) + #| + (define (lex-name in) + (string->symbol + (list->string + (let lex-rest () + (cond + [(name-char? (peek-char in)) + (cons (char-downcase (read-char in)) (lex-rest))] + [else null]))))) +|# + + + ;; skip-dtd : Input-port -> Void + (define (skip-dtd in) + (let skip () + (let ([c (read-char in)]) + (if (eof-object? c) + (void) + (case c + [(#\') (read-until #\' in) (skip)] + [(#\") (read-until #\" in) (skip)] + [(#\<) + (case (read-char in) + [(#\!) (case (read-char in) + [(#\-) (read-char in) (lex-comment-contents in) (skip)] + [else (skip) (skip)])] + [(#\?) (lex-pi-data in) (skip)] + [else (skip) (skip)])] + [(#\>) (void)] + [else (skip)]))))) + + ;; name-start? : TST -> Bool + (define (name-start? ch) + (and (char? ch) (char-name-start? ch))) + + ;; char-name-start? : Char -> Bool + (define (char-name-start? ch) + (or (char-alphabetic? ch) + (eq? ch #\_) + (eq? ch #\:))) + + ;; name-char? : TST -> Bool + (define (name-char? ch) + (and (char? ch) + (or (char-name-start? ch) + (char-numeric? ch) + (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database + (eq? ch #\.) + (eq? ch #\-)))) + + ;; read-up-to : (Char -> Bool) Input-port -> (listof Char) + ;; abstract this with read-until + (define (read-up-to p? in) + (let loop () + (let ([c (peek-char in)]) + (cond + [(or (eof-object? c) (p? c)) null] + [else (cons (read-char in) (loop))])))) + + ;; read-until : Char Input-port -> String + ;; discards the stop character, too + (define (read-until char in) + (list->string + (let read-more () + (let ([c (read-char in)]) + (cond + [(or (eof-object? c) (eq? c char)) null] + [else (cons c (read-more))]))))) + + ;; gen-read-until-string : String -> Input-port -> String + ;; uses Knuth-Morris-Pratt from + ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 + ;; discards stop from input + (define (gen-read-until-string stop) + (let* ([len (string-length stop)] + [prefix (make-vector len 0)] + [fall-back + (lambda (k c) + (let ([k (let loop ([k k]) + (cond + [(and (> k 0) (not (eq? (string-ref stop k) c))) + (loop (vector-ref prefix (sub1 k)))] + [else k]))]) + (if (eq? (string-ref stop k) c) + (add1 k) + k)))]) + (let init ([k 0] [q 1]) + (when (< q len) + (let ([k (fall-back k (string-ref stop q))]) + (vector-set! prefix q k) + (init k (add1 q))))) + ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop + (lambda (in) + (list->string + (let/ec out + (let loop ([matched 0] [out out]) + (let* ([c (read-char in)] + [matched (fall-back matched c)]) + (cond + [(or (eof-object? c) (= matched len)) (out null)] + [(zero? matched) (cons c (let/ec out (loop matched out)))] + [else (cons c (loop matched out))])))))))) + + ;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore. + (define lex-comment-contents (gen-read-until-string "-->")) + (define lex-pi-data (gen-read-until-string "?>")) + (define lex-cdata-contents (gen-read-until-string "]]>")) diff --git a/collects/tests/html/test.ss b/collects/tests/html/test.ss new file mode 100644 index 0000000000..2b53719672 --- /dev/null +++ b/collects/tests/html/test.ss @@ -0,0 +1,45 @@ +#lang scheme +(require (planet schematics/schemeunit:3) + (planet schematics/schemeunit:3/text-ui) + (prefix-in h: html) + (prefix-in x: xml)) + +(define html-tests + (test-suite + "HTML" + + (test-case + "Example" + (local + [(define an-html + (h:read-xhtml + (open-input-string + (string-append + "My title" + "

Hello world

Testing!

" + "")))) + + ; extract-pcdata: html-content -> (listof string) + ; Pulls out the pcdata strings from some-content. + (define (extract-pcdata some-content) + (cond [(x:pcdata? some-content) + (list (x:pcdata-string some-content))] + [(x:entity? some-content) + (list)] + [else + (extract-pcdata-from-element some-content)])) + + ; extract-pcdata-from-element: html-element -> (listof string) + ; Pulls out the pcdata strings from an-html-element. + (define (extract-pcdata-from-element an-html-element) + (match an-html-element + [(struct h:html-full (attributes content)) + (apply append (map extract-pcdata content))] + + [(struct h:html-element (attributes)) + '()]))] + + (check-equal? (extract-pcdata an-html) + ' ("My title" "Hello world" "Testing" "!")))))) + +(run-tests html-tests) \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/canonxml.html b/collects/tests/xml/clark-tests/canonxml.html new file mode 100644 index 0000000000..2ba0edf6c6 --- /dev/null +++ b/collects/tests/xml/clark-tests/canonxml.html @@ -0,0 +1,44 @@ + +Canonical XML + +

Canonical XML

+

+This document defines a subset of XML called canonical XML. +The intended use of canonical XML is in testing XML processors, +as a representation of the result of parsing an XML document. +

+Every well-formed XML document has a unique structurally equivalent +canonical XML document. Two structurally equivalent XML +documents have a byte-for-byte identical canonical XML document. +Canonicalizing an XML document requires only information that an XML +processor is required to make available to an application. +

+A canonical XML document conforms to the following grammar: +

+CanonXML    ::= Pi* element Pi*
+element     ::= Stag (Datachar | Pi | element)* Etag
+Stag        ::= '<'  Name Atts '>'
+Etag        ::= '</' Name '>'
+Pi          ::= '<?' Name ' ' (((Char - S) Char*)? - (Char* '?>' Char*)) '?>'
+Atts        ::= (' ' Name '=' '"' Datachar* '"')*
+Datachar    ::= '&amp;' | '&lt;' | '&gt;' | '&quot;'
+                 | '&#9;'| '&#10;'| '&#13;'
+                 | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD))
+Name        ::= (see XML spec)
+Char        ::= (see XML spec)
+S           ::= (see XML spec)
+
+

+Attributes are in lexicographical order (in Unicode bit order). +

+A canonical XML document is encoded in UTF-8. +

+Ignorable white space is considered significant and is treated equivalently +to data. +

+

+James Clark +
+ + + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/invalid/001.ent b/collects/tests/xml/clark-tests/invalid/001.ent new file mode 100644 index 0000000000..f70eaea9c4 --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/001.ent @@ -0,0 +1,3 @@ + + +%e; --> diff --git a/collects/tests/xml/clark-tests/invalid/001.xml b/collects/tests/xml/clark-tests/invalid/001.xml new file mode 100644 index 0000000000..36188451ae --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/001.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/invalid/002.ent b/collects/tests/xml/clark-tests/invalid/002.ent new file mode 100644 index 0000000000..4cb848b438 --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/002.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/invalid/002.xml b/collects/tests/xml/clark-tests/invalid/002.xml new file mode 100644 index 0000000000..5a3a96d1ab --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/002.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/invalid/003.ent b/collects/tests/xml/clark-tests/invalid/003.ent new file mode 100644 index 0000000000..54f3c821b8 --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/003.ent @@ -0,0 +1,2 @@ + +%e; doc (#PCDATA)> diff --git a/collects/tests/xml/clark-tests/invalid/003.xml b/collects/tests/xml/clark-tests/invalid/003.xml new file mode 100644 index 0000000000..dd01f41126 --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/003.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/invalid/004.ent b/collects/tests/xml/clark-tests/invalid/004.ent new file mode 100644 index 0000000000..aae4cc2929 --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/004.ent @@ -0,0 +1,3 @@ + +"> +%e1; doc (#PCDATA) %e2; diff --git a/collects/tests/xml/clark-tests/invalid/004.xml b/collects/tests/xml/clark-tests/invalid/004.xml new file mode 100644 index 0000000000..20cdf6d0e5 --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/004.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/invalid/005.ent b/collects/tests/xml/clark-tests/invalid/005.ent new file mode 100644 index 0000000000..85e16474a6 --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/005.ent @@ -0,0 +1,2 @@ +"> + + diff --git a/collects/tests/xml/clark-tests/invalid/006.ent b/collects/tests/xml/clark-tests/invalid/006.ent new file mode 100644 index 0000000000..116ca79657 --- /dev/null +++ b/collects/tests/xml/clark-tests/invalid/006.ent @@ -0,0 +1,2 @@ +"> + + diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent b/collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent new file mode 100644 index 0000000000..378a2074b7 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent @@ -0,0 +1 @@ +&e; \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml b/collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml new file mode 100644 index 0000000000..aa624cbe71 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml @@ -0,0 +1,4 @@ + +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent b/collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent new file mode 100644 index 0000000000..2cd184a213 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent @@ -0,0 +1,3 @@ + +data + diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml b/collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml new file mode 100644 index 0000000000..9eaf91724f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent b/collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent new file mode 100644 index 0000000000..35cf4892f2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent @@ -0,0 +1,2 @@ + +data diff --git a/collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml b/collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml new file mode 100644 index 0000000000..bb60b663ef --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/001.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/001.ent new file mode 100644 index 0000000000..00096e572e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/001.ent @@ -0,0 +1,3 @@ + +]> diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/001.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/001.xml new file mode 100644 index 0000000000..36188451ae --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/001.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/002.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/002.xml new file mode 100644 index 0000000000..dd73174135 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/002.xml @@ -0,0 +1,6 @@ + +"> +%e; +]> + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/003.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/003.ent new file mode 100644 index 0000000000..abf1b1a35e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/003.ent @@ -0,0 +1,2 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/004.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/004.ent new file mode 100644 index 0000000000..552e4f520a --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/004.ent @@ -0,0 +1,2 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/005.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/005.ent new file mode 100644 index 0000000000..9a369cef12 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/005.ent @@ -0,0 +1,2 @@ + +%e; diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/005.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/005.xml new file mode 100644 index 0000000000..383553d24f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/005.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/006.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/006.ent new file mode 100644 index 0000000000..771daf1915 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/006.ent @@ -0,0 +1,3 @@ + +]]> diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/006.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/006.xml new file mode 100644 index 0000000000..2f14e839e2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/006.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/007.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/007.ent new file mode 100644 index 0000000000..9e9866d2ad --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/007.ent @@ -0,0 +1,3 @@ + +]> diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/007.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/007.xml new file mode 100644 index 0000000000..38897e34ea --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/007.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/008.ent b/collects/tests/xml/clark-tests/not-wf/not-sa/008.ent new file mode 100644 index 0000000000..f8b1cd3dad --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/008.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/not-sa/008.xml b/collects/tests/xml/clark-tests/not-wf/not-sa/008.xml new file mode 100644 index 0000000000..54351009cd --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/not-sa/008.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/001.xml b/collects/tests/xml/clark-tests/not-wf/sa/001.xml new file mode 100644 index 0000000000..d33ec68dcd --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/001.xml @@ -0,0 +1,5 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/002.xml b/collects/tests/xml/clark-tests/not-wf/sa/002.xml new file mode 100644 index 0000000000..0a64d52428 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/002.xml @@ -0,0 +1,4 @@ + +<.doc> + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/003.xml b/collects/tests/xml/clark-tests/not-wf/sa/003.xml new file mode 100644 index 0000000000..e0b8bae4a4 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/003.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/004.xml b/collects/tests/xml/clark-tests/not-wf/sa/004.xml new file mode 100644 index 0000000000..e85bc96e56 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/004.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/005.xml b/collects/tests/xml/clark-tests/not-wf/sa/005.xml new file mode 100644 index 0000000000..7cd44ef10c --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/005.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/006.xml b/collects/tests/xml/clark-tests/not-wf/sa/006.xml new file mode 100644 index 0000000000..8594c35cc7 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/006.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/007.xml b/collects/tests/xml/clark-tests/not-wf/sa/007.xml new file mode 100644 index 0000000000..286756fdd5 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/007.xml @@ -0,0 +1 @@ +& no refc diff --git a/collects/tests/xml/clark-tests/not-wf/sa/008.xml b/collects/tests/xml/clark-tests/not-wf/sa/008.xml new file mode 100644 index 0000000000..29ef40306b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/008.xml @@ -0,0 +1 @@ +&.entity; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/009.xml b/collects/tests/xml/clark-tests/not-wf/sa/009.xml new file mode 100644 index 0000000000..8e3ff7de10 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/009.xml @@ -0,0 +1 @@ +&#RE; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/010.xml b/collects/tests/xml/clark-tests/not-wf/sa/010.xml new file mode 100644 index 0000000000..a6790846c9 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/010.xml @@ -0,0 +1 @@ +A & B diff --git a/collects/tests/xml/clark-tests/not-wf/sa/011.xml b/collects/tests/xml/clark-tests/not-wf/sa/011.xml new file mode 100644 index 0000000000..57eaf9fc48 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/011.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/012.xml b/collects/tests/xml/clark-tests/not-wf/sa/012.xml new file mode 100644 index 0000000000..1b2539ffa6 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/012.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/013.xml b/collects/tests/xml/clark-tests/not-wf/sa/013.xml new file mode 100644 index 0000000000..3540df9143 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/013.xml @@ -0,0 +1 @@ +"> diff --git a/collects/tests/xml/clark-tests/not-wf/sa/015.xml b/collects/tests/xml/clark-tests/not-wf/sa/015.xml new file mode 100644 index 0000000000..f2baf947b5 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/015.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/016.xml b/collects/tests/xml/clark-tests/not-wf/sa/016.xml new file mode 100644 index 0000000000..22d4b2e265 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/016.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/017.xml b/collects/tests/xml/clark-tests/not-wf/sa/017.xml new file mode 100644 index 0000000000..a76f5929e9 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/017.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/018.xml b/collects/tests/xml/clark-tests/not-wf/sa/018.xml new file mode 100644 index 0000000000..66e204acc4 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/018.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/019.xml b/collects/tests/xml/clark-tests/not-wf/sa/019.xml new file mode 100644 index 0000000000..b835c2d752 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/019.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/020.xml b/collects/tests/xml/clark-tests/not-wf/sa/020.xml new file mode 100644 index 0000000000..b30cfcfc10 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/020.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/021.xml b/collects/tests/xml/clark-tests/not-wf/sa/021.xml new file mode 100644 index 0000000000..1bfa84aa64 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/021.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/022.xml b/collects/tests/xml/clark-tests/not-wf/sa/022.xml new file mode 100644 index 0000000000..44c803bf1b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/022.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/023.xml b/collects/tests/xml/clark-tests/not-wf/sa/023.xml new file mode 100644 index 0000000000..b877ae2a6b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/023.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/024.xml b/collects/tests/xml/clark-tests/not-wf/sa/024.xml new file mode 100644 index 0000000000..cf68f2c073 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/024.xml @@ -0,0 +1,3 @@ + +<123> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/025.xml b/collects/tests/xml/clark-tests/not-wf/sa/025.xml new file mode 100644 index 0000000000..6cba95cd78 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/025.xml @@ -0,0 +1 @@ +]]> diff --git a/collects/tests/xml/clark-tests/not-wf/sa/026.xml b/collects/tests/xml/clark-tests/not-wf/sa/026.xml new file mode 100644 index 0000000000..347984fa73 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/026.xml @@ -0,0 +1 @@ +]]]> diff --git a/collects/tests/xml/clark-tests/not-wf/sa/027.xml b/collects/tests/xml/clark-tests/not-wf/sa/027.xml new file mode 100644 index 0000000000..cfafaf0d70 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/027.xml @@ -0,0 +1,3 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/033.xml b/collects/tests/xml/clark-tests/not-wf/sa/033.xml new file mode 100644 index 0000000000..afd2328402 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/033.xml @@ -0,0 +1 @@ +abcdef diff --git a/collects/tests/xml/clark-tests/not-wf/sa/034.xml b/collects/tests/xml/clark-tests/not-wf/sa/034.xml new file mode 100644 index 0000000000..d74a77719b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/034.xml @@ -0,0 +1 @@ +A form-feed is not white space or a name character diff --git a/collects/tests/xml/clark-tests/not-wf/sa/035.xml b/collects/tests/xml/clark-tests/not-wf/sa/035.xml new file mode 100644 index 0000000000..e1fc920522 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/035.xml @@ -0,0 +1 @@ +1 < 2 but not in XML diff --git a/collects/tests/xml/clark-tests/not-wf/sa/036.xml b/collects/tests/xml/clark-tests/not-wf/sa/036.xml new file mode 100644 index 0000000000..b8ecb21ba1 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/036.xml @@ -0,0 +1,2 @@ + +Illegal data diff --git a/collects/tests/xml/clark-tests/not-wf/sa/037.xml b/collects/tests/xml/clark-tests/not-wf/sa/037.xml new file mode 100644 index 0000000000..2e02662926 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/037.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/038.xml b/collects/tests/xml/clark-tests/not-wf/sa/038.xml new file mode 100644 index 0000000000..68b2803f82 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/038.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/039.xml b/collects/tests/xml/clark-tests/not-wf/sa/039.xml new file mode 100644 index 0000000000..80429e3e40 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/039.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/040.xml b/collects/tests/xml/clark-tests/not-wf/sa/040.xml new file mode 100644 index 0000000000..dc8ba5a434 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/040.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/041.xml b/collects/tests/xml/clark-tests/not-wf/sa/041.xml new file mode 100644 index 0000000000..30bcdd6bfe --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/041.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/042.xml b/collects/tests/xml/clark-tests/not-wf/sa/042.xml new file mode 100644 index 0000000000..4ae50efc7b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/042.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/043.xml b/collects/tests/xml/clark-tests/not-wf/sa/043.xml new file mode 100644 index 0000000000..41824eee4b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/043.xml @@ -0,0 +1,2 @@ + +Illegal data diff --git a/collects/tests/xml/clark-tests/not-wf/sa/044.xml b/collects/tests/xml/clark-tests/not-wf/sa/044.xml new file mode 100644 index 0000000000..3fc232dc37 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/044.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/045.xml b/collects/tests/xml/clark-tests/not-wf/sa/045.xml new file mode 100644 index 0000000000..00c10f00bf --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/045.xml @@ -0,0 +1,4 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/046.xml b/collects/tests/xml/clark-tests/not-wf/sa/046.xml new file mode 100644 index 0000000000..265cb15301 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/046.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/047.xml b/collects/tests/xml/clark-tests/not-wf/sa/047.xml new file mode 100644 index 0000000000..d18a4a4440 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/047.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/048.xml b/collects/tests/xml/clark-tests/not-wf/sa/048.xml new file mode 100644 index 0000000000..67419c1ed5 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/048.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/049.xml b/collects/tests/xml/clark-tests/not-wf/sa/049.xml new file mode 100644 index 0000000000..3cf0e79422 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/049.xml @@ -0,0 +1,4 @@ + + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/050.xml b/collects/tests/xml/clark-tests/not-wf/sa/050.xml new file mode 100644 index 0000000000..e69de29bb2 diff --git a/collects/tests/xml/clark-tests/not-wf/sa/051.xml b/collects/tests/xml/clark-tests/not-wf/sa/051.xml new file mode 100644 index 0000000000..b52df12cc4 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/051.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/052.xml b/collects/tests/xml/clark-tests/not-wf/sa/052.xml new file mode 100644 index 0000000000..8283895990 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/052.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/053.xml b/collects/tests/xml/clark-tests/not-wf/sa/053.xml new file mode 100644 index 0000000000..9d7f36920f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/053.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/054.xml b/collects/tests/xml/clark-tests/not-wf/sa/054.xml new file mode 100644 index 0000000000..eda553c6d3 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/054.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/055.xml b/collects/tests/xml/clark-tests/not-wf/sa/055.xml new file mode 100644 index 0000000000..cbb3683a9d --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/055.xml @@ -0,0 +1,2 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/056.xml b/collects/tests/xml/clark-tests/not-wf/sa/056.xml new file mode 100644 index 0000000000..a681684c58 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/056.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/057.xml b/collects/tests/xml/clark-tests/not-wf/sa/057.xml new file mode 100644 index 0000000000..848d347120 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/057.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/058.xml b/collects/tests/xml/clark-tests/not-wf/sa/058.xml new file mode 100644 index 0000000000..daba266af2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/058.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/059.xml b/collects/tests/xml/clark-tests/not-wf/sa/059.xml new file mode 100644 index 0000000000..316083dc25 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/059.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/060.xml b/collects/tests/xml/clark-tests/not-wf/sa/060.xml new file mode 100644 index 0000000000..9a610fd38f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/060.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/061.xml b/collects/tests/xml/clark-tests/not-wf/sa/061.xml new file mode 100644 index 0000000000..59181e706f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/061.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/062.xml b/collects/tests/xml/clark-tests/not-wf/sa/062.xml new file mode 100644 index 0000000000..e62e9cd370 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/062.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/063.xml b/collects/tests/xml/clark-tests/not-wf/sa/063.xml new file mode 100644 index 0000000000..98675b9040 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/063.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/064.xml b/collects/tests/xml/clark-tests/not-wf/sa/064.xml new file mode 100644 index 0000000000..3888c46b8b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/064.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/065.xml b/collects/tests/xml/clark-tests/not-wf/sa/065.xml new file mode 100644 index 0000000000..da9cafd137 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/065.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/066.xml b/collects/tests/xml/clark-tests/not-wf/sa/066.xml new file mode 100644 index 0000000000..9c09eb4e5d --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/066.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/067.xml b/collects/tests/xml/clark-tests/not-wf/sa/067.xml new file mode 100644 index 0000000000..7e0809bd34 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/067.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/068.xml b/collects/tests/xml/clark-tests/not-wf/sa/068.xml new file mode 100644 index 0000000000..53a80a83a8 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/068.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/069.xml b/collects/tests/xml/clark-tests/not-wf/sa/069.xml new file mode 100644 index 0000000000..6f891dd5e1 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/069.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/070.xml b/collects/tests/xml/clark-tests/not-wf/sa/070.xml new file mode 100644 index 0000000000..faf4b0ae4c --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/070.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/071.xml b/collects/tests/xml/clark-tests/not-wf/sa/071.xml new file mode 100644 index 0000000000..5bd3908968 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/071.xml @@ -0,0 +1,6 @@ + + + +]> +&e1; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/072.xml b/collects/tests/xml/clark-tests/not-wf/sa/072.xml new file mode 100644 index 0000000000..743ba79429 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/072.xml @@ -0,0 +1 @@ +&foo; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/073.xml b/collects/tests/xml/clark-tests/not-wf/sa/073.xml new file mode 100644 index 0000000000..2578af42ec --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/073.xml @@ -0,0 +1,4 @@ + +]> +&f; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/074.xml b/collects/tests/xml/clark-tests/not-wf/sa/074.xml new file mode 100644 index 0000000000..f8abaeb22c --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/074.xml @@ -0,0 +1,6 @@ +"> +]> + +&e; + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/075.xml b/collects/tests/xml/clark-tests/not-wf/sa/075.xml new file mode 100644 index 0000000000..d3dbf50ed6 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/075.xml @@ -0,0 +1,7 @@ + + + +]> + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/076.xml b/collects/tests/xml/clark-tests/not-wf/sa/076.xml new file mode 100644 index 0000000000..60546720e7 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/076.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/077.xml b/collects/tests/xml/clark-tests/not-wf/sa/077.xml new file mode 100644 index 0000000000..f8ac23a5a2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/077.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/078.xml b/collects/tests/xml/clark-tests/not-wf/sa/078.xml new file mode 100644 index 0000000000..446cd85ef9 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/078.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/079.xml b/collects/tests/xml/clark-tests/not-wf/sa/079.xml new file mode 100644 index 0000000000..da016fd3b2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/079.xml @@ -0,0 +1,8 @@ + + + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/080.xml b/collects/tests/xml/clark-tests/not-wf/sa/080.xml new file mode 100644 index 0000000000..fa4b9e428d --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/080.xml @@ -0,0 +1,8 @@ + + + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/081.xml b/collects/tests/xml/clark-tests/not-wf/sa/081.xml new file mode 100644 index 0000000000..d676100e8a --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/081.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/082.xml b/collects/tests/xml/clark-tests/not-wf/sa/082.xml new file mode 100644 index 0000000000..3217d6f8b4 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/082.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/083.xml b/collects/tests/xml/clark-tests/not-wf/sa/083.xml new file mode 100644 index 0000000000..469d43fd42 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/083.xml @@ -0,0 +1,4 @@ + +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/084.xml b/collects/tests/xml/clark-tests/not-wf/sa/084.xml new file mode 100644 index 0000000000..abbbcdea69 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/084.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/085.xml b/collects/tests/xml/clark-tests/not-wf/sa/085.xml new file mode 100644 index 0000000000..ac0aeca3e4 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/085.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/086.xml b/collects/tests/xml/clark-tests/not-wf/sa/086.xml new file mode 100644 index 0000000000..df6adfd884 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/086.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/087.xml b/collects/tests/xml/clark-tests/not-wf/sa/087.xml new file mode 100644 index 0000000000..ed49492a7a --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/087.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/088.xml b/collects/tests/xml/clark-tests/not-wf/sa/088.xml new file mode 100644 index 0000000000..da0a68c401 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/088.xml @@ -0,0 +1,6 @@ + + + +]> + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/090.xml b/collects/tests/xml/clark-tests/not-wf/sa/090.xml new file mode 100644 index 0000000000..3fb72f3cc0 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/090.xml @@ -0,0 +1,4 @@ +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/091.xml b/collects/tests/xml/clark-tests/not-wf/sa/091.xml new file mode 100644 index 0000000000..a61d0914f8 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/091.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/092.xml b/collects/tests/xml/clark-tests/not-wf/sa/092.xml new file mode 100644 index 0000000000..be5266dada --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/092.xml @@ -0,0 +1,4 @@ +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/093.xml b/collects/tests/xml/clark-tests/not-wf/sa/093.xml new file mode 100644 index 0000000000..4af61bc645 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/093.xml @@ -0,0 +1 @@ +X diff --git a/collects/tests/xml/clark-tests/not-wf/sa/094.xml b/collects/tests/xml/clark-tests/not-wf/sa/094.xml new file mode 100644 index 0000000000..bdec7a4660 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/094.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/095.xml b/collects/tests/xml/clark-tests/not-wf/sa/095.xml new file mode 100644 index 0000000000..090b8b4eec --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/095.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/096.xml b/collects/tests/xml/clark-tests/not-wf/sa/096.xml new file mode 100644 index 0000000000..d806c3b952 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/096.xml @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/not-wf/sa/097.xml b/collects/tests/xml/clark-tests/not-wf/sa/097.xml new file mode 100644 index 0000000000..d4def544b0 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/097.xml @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/not-wf/sa/098.xml b/collects/tests/xml/clark-tests/not-wf/sa/098.xml new file mode 100644 index 0000000000..9798496aa3 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/098.xml @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/not-wf/sa/099.xml b/collects/tests/xml/clark-tests/not-wf/sa/099.xml new file mode 100644 index 0000000000..d5be08eff0 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/099.xml @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/not-wf/sa/100.xml b/collects/tests/xml/clark-tests/not-wf/sa/100.xml new file mode 100644 index 0000000000..51e06231c2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/100.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/101.xml b/collects/tests/xml/clark-tests/not-wf/sa/101.xml new file mode 100644 index 0000000000..afa5a455fc --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/101.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/102.xml b/collects/tests/xml/clark-tests/not-wf/sa/102.xml new file mode 100644 index 0000000000..8734adaa6e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/102.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/103.xml b/collects/tests/xml/clark-tests/not-wf/sa/103.xml new file mode 100644 index 0000000000..6c4716798f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/103.xml @@ -0,0 +1,4 @@ +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/104.xml b/collects/tests/xml/clark-tests/not-wf/sa/104.xml new file mode 100644 index 0000000000..dd57396239 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/104.xml @@ -0,0 +1,4 @@ +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/105.xml b/collects/tests/xml/clark-tests/not-wf/sa/105.xml new file mode 100644 index 0000000000..809e705870 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/105.xml @@ -0,0 +1,4 @@ + + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/106.xml b/collects/tests/xml/clark-tests/not-wf/sa/106.xml new file mode 100644 index 0000000000..d32319ef09 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/106.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/107.xml b/collects/tests/xml/clark-tests/not-wf/sa/107.xml new file mode 100644 index 0000000000..3dfd8200e2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/107.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/108.xml b/collects/tests/xml/clark-tests/not-wf/sa/108.xml new file mode 100644 index 0000000000..af5cf50d48 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/108.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/109.xml b/collects/tests/xml/clark-tests/not-wf/sa/109.xml new file mode 100644 index 0000000000..5afc03e8db --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/109.xml @@ -0,0 +1,4 @@ +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/110.xml b/collects/tests/xml/clark-tests/not-wf/sa/110.xml new file mode 100644 index 0000000000..cf54ebe5c0 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/110.xml @@ -0,0 +1,5 @@ + +]> + +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/111.xml b/collects/tests/xml/clark-tests/not-wf/sa/111.xml new file mode 100644 index 0000000000..84a469f5d1 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/111.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/112.xml b/collects/tests/xml/clark-tests/not-wf/sa/112.xml new file mode 100644 index 0000000000..0c5c1a4341 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/112.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/113.xml b/collects/tests/xml/clark-tests/not-wf/sa/113.xml new file mode 100644 index 0000000000..04fc9d2318 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/113.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/114.xml b/collects/tests/xml/clark-tests/not-wf/sa/114.xml new file mode 100644 index 0000000000..1261ee49e1 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/114.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/115.xml b/collects/tests/xml/clark-tests/not-wf/sa/115.xml new file mode 100644 index 0000000000..f111dbe153 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/115.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/116.xml b/collects/tests/xml/clark-tests/not-wf/sa/116.xml new file mode 100644 index 0000000000..84bb762fdf --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/116.xml @@ -0,0 +1,4 @@ + +]> +&e;7; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/117.xml b/collects/tests/xml/clark-tests/not-wf/sa/117.xml new file mode 100644 index 0000000000..e4a5e572ef --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/117.xml @@ -0,0 +1,4 @@ + +]> +&e;#97; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/118.xml b/collects/tests/xml/clark-tests/not-wf/sa/118.xml new file mode 100644 index 0000000000..494d53d208 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/118.xml @@ -0,0 +1,4 @@ + +]> +&&e;97; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/119.xml b/collects/tests/xml/clark-tests/not-wf/sa/119.xml new file mode 100644 index 0000000000..aefaa44a1c --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/119.xml @@ -0,0 +1,6 @@ + +]> + +&e;#38; + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/120.xml b/collects/tests/xml/clark-tests/not-wf/sa/120.xml new file mode 100644 index 0000000000..b7d6ff9ce9 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/120.xml @@ -0,0 +1,6 @@ + +]> + +&e; + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/121.xml b/collects/tests/xml/clark-tests/not-wf/sa/121.xml new file mode 100644 index 0000000000..2b4adcc6b4 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/121.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/122.xml b/collects/tests/xml/clark-tests/not-wf/sa/122.xml new file mode 100644 index 0000000000..ef0b057cee --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/122.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/123.xml b/collects/tests/xml/clark-tests/not-wf/sa/123.xml new file mode 100644 index 0000000000..06d65f045b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/123.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/124.xml b/collects/tests/xml/clark-tests/not-wf/sa/124.xml new file mode 100644 index 0000000000..3bbe0f91a6 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/124.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/125.xml b/collects/tests/xml/clark-tests/not-wf/sa/125.xml new file mode 100644 index 0000000000..5f9c22c0c6 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/125.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/126.xml b/collects/tests/xml/clark-tests/not-wf/sa/126.xml new file mode 100644 index 0000000000..13e74d6d5e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/126.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/127.xml b/collects/tests/xml/clark-tests/not-wf/sa/127.xml new file mode 100644 index 0000000000..a379b9e539 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/127.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/128.xml b/collects/tests/xml/clark-tests/not-wf/sa/128.xml new file mode 100644 index 0000000000..dd706bb21f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/128.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/129.xml b/collects/tests/xml/clark-tests/not-wf/sa/129.xml new file mode 100644 index 0000000000..d4e4461a6d --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/129.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/130.xml b/collects/tests/xml/clark-tests/not-wf/sa/130.xml new file mode 100644 index 0000000000..fa7be641f1 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/130.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/131.xml b/collects/tests/xml/clark-tests/not-wf/sa/131.xml new file mode 100644 index 0000000000..f34ed453b5 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/131.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/132.xml b/collects/tests/xml/clark-tests/not-wf/sa/132.xml new file mode 100644 index 0000000000..ab6cc416e9 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/132.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/133.xml b/collects/tests/xml/clark-tests/not-wf/sa/133.xml new file mode 100644 index 0000000000..d2aa604e9f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/133.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/134.xml b/collects/tests/xml/clark-tests/not-wf/sa/134.xml new file mode 100644 index 0000000000..c8919c5ef8 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/134.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/135.xml b/collects/tests/xml/clark-tests/not-wf/sa/135.xml new file mode 100644 index 0000000000..e639e8b6ea --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/135.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/136.xml b/collects/tests/xml/clark-tests/not-wf/sa/136.xml new file mode 100644 index 0000000000..499e68bcea --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/136.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/137.xml b/collects/tests/xml/clark-tests/not-wf/sa/137.xml new file mode 100644 index 0000000000..723b77f776 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/137.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/138.xml b/collects/tests/xml/clark-tests/not-wf/sa/138.xml new file mode 100644 index 0000000000..16934cc88e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/138.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/139.xml b/collects/tests/xml/clark-tests/not-wf/sa/139.xml new file mode 100644 index 0000000000..34df52ed93 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/139.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/140.xml b/collects/tests/xml/clark-tests/not-wf/sa/140.xml new file mode 100644 index 0000000000..467d5ed301 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/140.xml @@ -0,0 +1,4 @@ +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/141.xml b/collects/tests/xml/clark-tests/not-wf/sa/141.xml new file mode 100644 index 0000000000..409d0a7568 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/141.xml @@ -0,0 +1,4 @@ +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/142.xml b/collects/tests/xml/clark-tests/not-wf/sa/142.xml new file mode 100644 index 0000000000..20e88f88b3 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/142.xml @@ -0,0 +1,4 @@ + +]> +� diff --git a/collects/tests/xml/clark-tests/not-wf/sa/143.xml b/collects/tests/xml/clark-tests/not-wf/sa/143.xml new file mode 100644 index 0000000000..0ee1c614f8 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/143.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/144.xml b/collects/tests/xml/clark-tests/not-wf/sa/144.xml new file mode 100644 index 0000000000..437548c0ba --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/144.xml @@ -0,0 +1,4 @@ + +]> +￿ diff --git a/collects/tests/xml/clark-tests/not-wf/sa/145.xml b/collects/tests/xml/clark-tests/not-wf/sa/145.xml new file mode 100644 index 0000000000..71b187a933 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/145.xml @@ -0,0 +1,4 @@ + +]> +� diff --git a/collects/tests/xml/clark-tests/not-wf/sa/146.xml b/collects/tests/xml/clark-tests/not-wf/sa/146.xml new file mode 100644 index 0000000000..d0bfbca723 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/146.xml @@ -0,0 +1,4 @@ + +]> +� diff --git a/collects/tests/xml/clark-tests/not-wf/sa/147.xml b/collects/tests/xml/clark-tests/not-wf/sa/147.xml new file mode 100644 index 0000000000..3b6145615f --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/147.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/148.xml b/collects/tests/xml/clark-tests/not-wf/sa/148.xml new file mode 100644 index 0000000000..774dce18fd --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/148.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/149.xml b/collects/tests/xml/clark-tests/not-wf/sa/149.xml new file mode 100644 index 0000000000..725eea0dec --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/149.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/150.xml b/collects/tests/xml/clark-tests/not-wf/sa/150.xml new file mode 100644 index 0000000000..44f6b6df92 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/150.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/151.xml b/collects/tests/xml/clark-tests/not-wf/sa/151.xml new file mode 100644 index 0000000000..fecc4f24e3 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/151.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/152.xml b/collects/tests/xml/clark-tests/not-wf/sa/152.xml new file mode 100644 index 0000000000..b5c5cb26ae --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/152.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/153.xml b/collects/tests/xml/clark-tests/not-wf/sa/153.xml new file mode 100644 index 0000000000..5e2973707e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/153.xml @@ -0,0 +1,5 @@ + +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/154.xml b/collects/tests/xml/clark-tests/not-wf/sa/154.xml new file mode 100644 index 0000000000..96e01d63f5 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/154.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/155.xml b/collects/tests/xml/clark-tests/not-wf/sa/155.xml new file mode 100644 index 0000000000..4f16d0f163 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/155.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/156.xml b/collects/tests/xml/clark-tests/not-wf/sa/156.xml new file mode 100644 index 0000000000..c6d93fd312 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/156.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/157.xml b/collects/tests/xml/clark-tests/not-wf/sa/157.xml new file mode 100644 index 0000000000..2f058dac3e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/157.xml @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/158.xml b/collects/tests/xml/clark-tests/not-wf/sa/158.xml new file mode 100644 index 0000000000..32b90b722d --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/158.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/159.xml b/collects/tests/xml/clark-tests/not-wf/sa/159.xml new file mode 100644 index 0000000000..066244cb91 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/159.xml @@ -0,0 +1,5 @@ + +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/160.xml b/collects/tests/xml/clark-tests/not-wf/sa/160.xml new file mode 100644 index 0000000000..85424acb1b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/160.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/161.xml b/collects/tests/xml/clark-tests/not-wf/sa/161.xml new file mode 100644 index 0000000000..4f8a5b7b6b --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/161.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/162.xml b/collects/tests/xml/clark-tests/not-wf/sa/162.xml new file mode 100644 index 0000000000..efae4b190e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/162.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/163.xml b/collects/tests/xml/clark-tests/not-wf/sa/163.xml new file mode 100644 index 0000000000..e14fb76c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/163.xml @@ -0,0 +1,6 @@ + + +]> +%e; + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/164.xml b/collects/tests/xml/clark-tests/not-wf/sa/164.xml new file mode 100644 index 0000000000..98dd267c21 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/164.xml @@ -0,0 +1,5 @@ + + +] %e; > + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/165.xml b/collects/tests/xml/clark-tests/not-wf/sa/165.xml new file mode 100644 index 0000000000..36c04618ef --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/165.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/166.xml b/collects/tests/xml/clark-tests/not-wf/sa/166.xml new file mode 100644 index 0000000000..ee2ce28630 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/166.xml @@ -0,0 +1 @@ +￿ diff --git a/collects/tests/xml/clark-tests/not-wf/sa/167.xml b/collects/tests/xml/clark-tests/not-wf/sa/167.xml new file mode 100644 index 0000000000..9bdc6c1278 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/167.xml @@ -0,0 +1 @@ +￾ diff --git a/collects/tests/xml/clark-tests/not-wf/sa/168.xml b/collects/tests/xml/clark-tests/not-wf/sa/168.xml new file mode 100644 index 0000000000..f83221a3ad --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/168.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/169.xml b/collects/tests/xml/clark-tests/not-wf/sa/169.xml new file mode 100644 index 0000000000..310029b976 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/169.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/170.xml b/collects/tests/xml/clark-tests/not-wf/sa/170.xml new file mode 100644 index 0000000000..cfa0aee155 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/170.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/171.xml b/collects/tests/xml/clark-tests/not-wf/sa/171.xml new file mode 100644 index 0000000000..48b5c7d3bc --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/171.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/172.xml b/collects/tests/xml/clark-tests/not-wf/sa/172.xml new file mode 100644 index 0000000000..6651d4d299 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/172.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/173.xml b/collects/tests/xml/clark-tests/not-wf/sa/173.xml new file mode 100644 index 0000000000..f9f9f42023 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/173.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/174.xml b/collects/tests/xml/clark-tests/not-wf/sa/174.xml new file mode 100644 index 0000000000..42bef861c6 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/174.xml @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/175.xml b/collects/tests/xml/clark-tests/not-wf/sa/175.xml new file mode 100644 index 0000000000..69912f36d2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/175.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/176.xml b/collects/tests/xml/clark-tests/not-wf/sa/176.xml new file mode 100644 index 0000000000..39153ad5a8 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/176.xml @@ -0,0 +1,4 @@ + +]> + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/not-wf/sa/177.xml b/collects/tests/xml/clark-tests/not-wf/sa/177.xml new file mode 100644 index 0000000000..6bc8228879 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/177.xml @@ -0,0 +1,4 @@ + +]> +A￿ diff --git a/collects/tests/xml/clark-tests/not-wf/sa/178.xml b/collects/tests/xml/clark-tests/not-wf/sa/178.xml new file mode 100644 index 0000000000..e8f2d18eed --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/178.xml @@ -0,0 +1,5 @@ + + +]> + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/180.xml b/collects/tests/xml/clark-tests/not-wf/sa/180.xml new file mode 100644 index 0000000000..569d553a8c --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/180.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/181.xml b/collects/tests/xml/clark-tests/not-wf/sa/181.xml new file mode 100644 index 0000000000..4341d99ee2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/181.xml @@ -0,0 +1,5 @@ + + +]> +&e;]]> diff --git a/collects/tests/xml/clark-tests/not-wf/sa/182.xml b/collects/tests/xml/clark-tests/not-wf/sa/182.xml new file mode 100644 index 0000000000..920f431666 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/182.xml @@ -0,0 +1,5 @@ + + +]> +&e;--> diff --git a/collects/tests/xml/clark-tests/not-wf/sa/183.xml b/collects/tests/xml/clark-tests/not-wf/sa/183.xml new file mode 100644 index 0000000000..7a5677de54 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/183.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/184.xml b/collects/tests/xml/clark-tests/not-wf/sa/184.xml new file mode 100644 index 0000000000..103384a06e --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/184.xml @@ -0,0 +1,6 @@ + + +]> + + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/185.ent b/collects/tests/xml/clark-tests/not-wf/sa/185.ent new file mode 100644 index 0000000000..e557426454 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/185.ent @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/185.xml b/collects/tests/xml/clark-tests/not-wf/sa/185.xml new file mode 100644 index 0000000000..81d5ef4bcd --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/185.xml @@ -0,0 +1,3 @@ + + +&e; diff --git a/collects/tests/xml/clark-tests/not-wf/sa/186.xml b/collects/tests/xml/clark-tests/not-wf/sa/186.xml new file mode 100644 index 0000000000..85b26ec0a2 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/186.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/not-wf/sa/null.ent b/collects/tests/xml/clark-tests/not-wf/sa/null.ent new file mode 100644 index 0000000000..e69de29bb2 diff --git a/collects/tests/xml/clark-tests/readme.html b/collects/tests/xml/clark-tests/readme.html new file mode 100644 index 0000000000..fc7310c68e --- /dev/null +++ b/collects/tests/xml/clark-tests/readme.html @@ -0,0 +1,60 @@ + +XML Test Cases + +

XML Test Cases version 1998-11-18

+

+Copyright (C) 1998 James Clark. All rights reserved. Permission is +granted to copy and modify this collection in any way for internal use +within a company or organization. Permission is granted to +redistribute the file xmltest.zip containing this +collection to third parties provided that no modifications of any kind +are made to this file. Note that permission to distribute the +collection in any other form is not granted. +

+The collection is structured into three directories: +

+
not-wf +
this contains cases that are not well-formed XML documents +
valid +
this contains cases that are valid XML documents +
invalid +
this contains cases that are well-formed XML documents +but are not valid XML documents +
+

+The not-wf and valid directories each have +three subdirectories: +

+
+sa +
+this contains cases that are standalone (as defined in XML) and do not +have references to external general entities +
+ext-sa +
+this contains case that are standalone and have references to external +general entities +
+not-sa +
+this contains cases that are not standalone +
+

+In each directory, files with a .xml extension are the +XML document test cases, and files with a .ent extension +are external entities referenced by the test cases. +

+Within the valid directory, each of these three +subdirectories has an out subdirectory which contains an +equivalent canonical XML document for each +of the cases. +

+

+Bug reports and contributions of new test cases are welcome. +

+

+James Clark +
+ + diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/001.ent b/collects/tests/xml/clark-tests/valid/ext-sa/001.ent new file mode 100644 index 0000000000..1cff3fd44f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/001.ent @@ -0,0 +1 @@ +Data diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/001.xml b/collects/tests/xml/clark-tests/valid/ext-sa/001.xml new file mode 100644 index 0000000000..147d70d2d1 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/001.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/002.ent b/collects/tests/xml/clark-tests/valid/ext-sa/002.ent new file mode 100644 index 0000000000..45f6d8e74e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/002.ent @@ -0,0 +1 @@ +Data \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/002.xml b/collects/tests/xml/clark-tests/valid/ext-sa/002.xml new file mode 100644 index 0000000000..9eaf91724f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/002.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/003.ent b/collects/tests/xml/clark-tests/valid/ext-sa/003.ent new file mode 100644 index 0000000000..e69de29bb2 diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/003.xml b/collects/tests/xml/clark-tests/valid/ext-sa/003.xml new file mode 100644 index 0000000000..bb60b663ef --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/003.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/004.ent b/collects/tests/xml/clark-tests/valid/ext-sa/004.ent new file mode 100644 index 0000000000..3436f20001 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/004.ent @@ -0,0 +1 @@ +Data \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/004.xml b/collects/tests/xml/clark-tests/valid/ext-sa/004.xml new file mode 100644 index 0000000000..074498ce19 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/004.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/005.ent b/collects/tests/xml/clark-tests/valid/ext-sa/005.ent new file mode 100644 index 0000000000..c6e97f821f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/005.ent @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/005.xml b/collects/tests/xml/clark-tests/valid/ext-sa/005.xml new file mode 100644 index 0000000000..82a6228205 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/005.xml @@ -0,0 +1,6 @@ + + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/006.ent b/collects/tests/xml/clark-tests/valid/ext-sa/006.ent new file mode 100644 index 0000000000..4df2f0c2ac --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/006.ent @@ -0,0 +1,4 @@ +Data + +More data + diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/006.xml b/collects/tests/xml/clark-tests/valid/ext-sa/006.xml new file mode 100644 index 0000000000..0b326cad4c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/006.xml @@ -0,0 +1,6 @@ + + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/007.ent b/collects/tests/xml/clark-tests/valid/ext-sa/007.ent new file mode 100644 index 0000000000000000000000000000000000000000..ab1d696dd7de7a33dce7d7992453873aaa053cd8 GIT binary patch literal 4 LcmezWFOmTO2dn~D literal 0 HcmV?d00001 diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/007.xml b/collects/tests/xml/clark-tests/valid/ext-sa/007.xml new file mode 100644 index 0000000000..825e3b286a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/007.xml @@ -0,0 +1,5 @@ + + +]> +X&e;Z diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/008.ent b/collects/tests/xml/clark-tests/valid/ext-sa/008.ent new file mode 100644 index 0000000000000000000000000000000000000000..c6ca61f9c8589942bb81ae508c0e3e417d67880a GIT binary patch literal 54 zcmezW&xXOCp@JcoA%{VMA(bJIA(>2DB GA{hWxy$TBe literal 0 HcmV?d00001 diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/008.xml b/collects/tests/xml/clark-tests/valid/ext-sa/008.xml new file mode 100644 index 0000000000..3c001b6cb3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/008.xml @@ -0,0 +1,5 @@ + + +]> +X&e;Z diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/009.ent b/collects/tests/xml/clark-tests/valid/ext-sa/009.ent new file mode 100644 index 0000000000..67c3297611 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/009.ent @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/009.xml b/collects/tests/xml/clark-tests/valid/ext-sa/009.xml new file mode 100644 index 0000000000..a5866e5a77 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/009.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/010.ent b/collects/tests/xml/clark-tests/valid/ext-sa/010.ent new file mode 100644 index 0000000000..e69de29bb2 diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/010.xml b/collects/tests/xml/clark-tests/valid/ext-sa/010.xml new file mode 100644 index 0000000000..418e9b0141 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/010.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/011.ent b/collects/tests/xml/clark-tests/valid/ext-sa/011.ent new file mode 100644 index 0000000000..b19be3a497 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/011.ent @@ -0,0 +1 @@ +xyzzy diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/011.xml b/collects/tests/xml/clark-tests/valid/ext-sa/011.xml new file mode 100644 index 0000000000..2ceefa1d21 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/011.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/012.ent b/collects/tests/xml/clark-tests/valid/ext-sa/012.ent new file mode 100644 index 0000000000..8eb1fb9c41 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/012.ent @@ -0,0 +1 @@ +&e4; \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/012.xml b/collects/tests/xml/clark-tests/valid/ext-sa/012.xml new file mode 100644 index 0000000000..5a8f009b4a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/012.xml @@ -0,0 +1,9 @@ + + + + + + +]> +&e1; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/013.ent b/collects/tests/xml/clark-tests/valid/ext-sa/013.ent new file mode 100644 index 0000000000..7f25c502dd --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/013.ent @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/013.xml b/collects/tests/xml/clark-tests/valid/ext-sa/013.xml new file mode 100644 index 0000000000..7717c97afe --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/013.xml @@ -0,0 +1,10 @@ + + + + +]> +&x; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/014.ent b/collects/tests/xml/clark-tests/valid/ext-sa/014.ent new file mode 100644 index 0000000000000000000000000000000000000000..470fd6fe4455fdaa2e3e1941babdaed228da676a GIT binary patch literal 12 ScmezW@BhCPhD3%EAO-+2#s!rC literal 0 HcmV?d00001 diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/014.xml b/collects/tests/xml/clark-tests/valid/ext-sa/014.xml new file mode 100644 index 0000000000..816fd1e796 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/014.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/001.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/001.xml new file mode 100644 index 0000000000..0a7acf8ebe --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/001.xml @@ -0,0 +1 @@ +Data \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/002.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/002.xml new file mode 100644 index 0000000000..d4a445e555 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/002.xml @@ -0,0 +1 @@ +Data \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/003.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/003.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/003.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/004.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/004.xml new file mode 100644 index 0000000000..0a7acf8ebe --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/004.xml @@ -0,0 +1 @@ +Data \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/005.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/005.xml new file mode 100644 index 0000000000..6e293aa70e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/005.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/006.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/006.xml new file mode 100644 index 0000000000..04b6fc82ee --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/006.xml @@ -0,0 +1 @@ +Data More data \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/007.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/007.xml new file mode 100644 index 0000000000..ab2a74c9d1 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/007.xml @@ -0,0 +1 @@ +XYZ \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/008.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/008.xml new file mode 100644 index 0000000000..ab2a74c9d1 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/008.xml @@ -0,0 +1 @@ +XYZ \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/009.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/009.xml new file mode 100644 index 0000000000..a79dff65fd --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/009.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/010.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/010.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/010.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/011.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/011.xml new file mode 100644 index 0000000000..bf275adb2b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/011.xml @@ -0,0 +1 @@ +xyzzy \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/012.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/012.xml new file mode 100644 index 0000000000..81a251cb4b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/012.xml @@ -0,0 +1 @@ +(e5) \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/013.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/013.xml new file mode 100644 index 0000000000..524d94ee6b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/013.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/ext-sa/out/014.xml b/collects/tests/xml/clark-tests/valid/ext-sa/out/014.xml new file mode 100644 index 0000000000..71c6dc3e8e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/ext-sa/out/014.xml @@ -0,0 +1 @@ +data \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/001.ent b/collects/tests/xml/clark-tests/valid/not-sa/001.ent new file mode 100644 index 0000000000..e69de29bb2 diff --git a/collects/tests/xml/clark-tests/valid/not-sa/001.xml b/collects/tests/xml/clark-tests/valid/not-sa/001.xml new file mode 100644 index 0000000000..2d6f41a137 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/001.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/002.ent b/collects/tests/xml/clark-tests/valid/not-sa/002.ent new file mode 100644 index 0000000000..67c3297611 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/002.ent @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/002.xml b/collects/tests/xml/clark-tests/valid/not-sa/002.xml new file mode 100644 index 0000000000..023fce8499 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/002.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/003-1.ent b/collects/tests/xml/clark-tests/valid/not-sa/003-1.ent new file mode 100644 index 0000000000..931f3ad6d8 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/003-1.ent @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/003-2.ent b/collects/tests/xml/clark-tests/valid/not-sa/003-2.ent new file mode 100644 index 0000000000..e69de29bb2 diff --git a/collects/tests/xml/clark-tests/valid/not-sa/003.xml b/collects/tests/xml/clark-tests/valid/not-sa/003.xml new file mode 100644 index 0000000000..63a5e8bdfc --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/003.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/004-1.ent b/collects/tests/xml/clark-tests/valid/not-sa/004-1.ent new file mode 100644 index 0000000000..40f7ff58a2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/004-1.ent @@ -0,0 +1,4 @@ + + + +%e1; diff --git a/collects/tests/xml/clark-tests/valid/not-sa/004-2.ent b/collects/tests/xml/clark-tests/valid/not-sa/004-2.ent new file mode 100644 index 0000000000..61def75cb7 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/004-2.ent @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/004.xml b/collects/tests/xml/clark-tests/valid/not-sa/004.xml new file mode 100644 index 0000000000..adc9201496 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/004.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/005-1.ent b/collects/tests/xml/clark-tests/valid/not-sa/005-1.ent new file mode 100644 index 0000000000..ade9599032 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/005-1.ent @@ -0,0 +1,3 @@ + + +%e; diff --git a/collects/tests/xml/clark-tests/valid/not-sa/005-2.ent b/collects/tests/xml/clark-tests/valid/not-sa/005-2.ent new file mode 100644 index 0000000000..bef50b1f38 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/005-2.ent @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/005.xml b/collects/tests/xml/clark-tests/valid/not-sa/005.xml new file mode 100644 index 0000000000..6bd44cfee0 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/005.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/006.ent b/collects/tests/xml/clark-tests/valid/not-sa/006.ent new file mode 100644 index 0000000000..8f305a82bd --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/006.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/006.xml b/collects/tests/xml/clark-tests/valid/not-sa/006.xml new file mode 100644 index 0000000000..eb80bb7409 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/006.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/007.ent b/collects/tests/xml/clark-tests/valid/not-sa/007.ent new file mode 100644 index 0000000000..fbf4ca4947 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/007.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/007.xml b/collects/tests/xml/clark-tests/valid/not-sa/007.xml new file mode 100644 index 0000000000..38897e34ea --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/007.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/008.ent b/collects/tests/xml/clark-tests/valid/not-sa/008.ent new file mode 100644 index 0000000000..fbf4ca4947 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/008.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/008.xml b/collects/tests/xml/clark-tests/valid/not-sa/008.xml new file mode 100644 index 0000000000..bf777a7ff2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/008.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/009.ent b/collects/tests/xml/clark-tests/valid/not-sa/009.ent new file mode 100644 index 0000000000..fbf4ca4947 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/009.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/009.xml b/collects/tests/xml/clark-tests/valid/not-sa/009.xml new file mode 100644 index 0000000000..c17562fe68 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/009.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/010.ent b/collects/tests/xml/clark-tests/valid/not-sa/010.ent new file mode 100644 index 0000000000..52a28f5deb --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/010.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/010.xml b/collects/tests/xml/clark-tests/valid/not-sa/010.xml new file mode 100644 index 0000000000..2786b328f3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/010.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/011.ent b/collects/tests/xml/clark-tests/valid/not-sa/011.ent new file mode 100644 index 0000000000..fbf4ca4947 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/011.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/011.xml b/collects/tests/xml/clark-tests/valid/not-sa/011.xml new file mode 100644 index 0000000000..03b482bbb6 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/011.xml @@ -0,0 +1,5 @@ + +%e; +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/012.ent b/collects/tests/xml/clark-tests/valid/not-sa/012.ent new file mode 100644 index 0000000000..7e372e65e9 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/012.ent @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/012.xml b/collects/tests/xml/clark-tests/valid/not-sa/012.xml new file mode 100644 index 0000000000..1967edbba7 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/012.xml @@ -0,0 +1,5 @@ + +%e; +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/013.ent b/collects/tests/xml/clark-tests/valid/not-sa/013.ent new file mode 100644 index 0000000000..a3691d9f08 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/013.ent @@ -0,0 +1,4 @@ + + +]]> diff --git a/collects/tests/xml/clark-tests/valid/not-sa/013.xml b/collects/tests/xml/clark-tests/valid/not-sa/013.xml new file mode 100644 index 0000000000..cf44f2600a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/013.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/014.ent b/collects/tests/xml/clark-tests/valid/not-sa/014.ent new file mode 100644 index 0000000000..6eaf779329 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/014.ent @@ -0,0 +1,4 @@ + + +]]> diff --git a/collects/tests/xml/clark-tests/valid/not-sa/014.xml b/collects/tests/xml/clark-tests/valid/not-sa/014.xml new file mode 100644 index 0000000000..bd08502489 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/014.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/015.ent b/collects/tests/xml/clark-tests/valid/not-sa/015.ent new file mode 100644 index 0000000000..00d2f30e1d --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/015.ent @@ -0,0 +1,5 @@ + + +]]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/015.xml b/collects/tests/xml/clark-tests/valid/not-sa/015.xml new file mode 100644 index 0000000000..e04e75ffca --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/015.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/016.ent b/collects/tests/xml/clark-tests/valid/not-sa/016.ent new file mode 100644 index 0000000000..bf77ef8336 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/016.ent @@ -0,0 +1,4 @@ + + +]]> diff --git a/collects/tests/xml/clark-tests/valid/not-sa/016.xml b/collects/tests/xml/clark-tests/valid/not-sa/016.xml new file mode 100644 index 0000000000..4ccf4af350 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/016.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/017.ent b/collects/tests/xml/clark-tests/valid/not-sa/017.ent new file mode 100644 index 0000000000..ffd9adde61 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/017.ent @@ -0,0 +1,3 @@ + +"> +%e; diff --git a/collects/tests/xml/clark-tests/valid/not-sa/017.xml b/collects/tests/xml/clark-tests/valid/not-sa/017.xml new file mode 100644 index 0000000000..7fe18f4c7a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/017.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/018.ent b/collects/tests/xml/clark-tests/valid/not-sa/018.ent new file mode 100644 index 0000000000..2d46f76fc3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/018.ent @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/018.xml b/collects/tests/xml/clark-tests/valid/not-sa/018.xml new file mode 100644 index 0000000000..31e90f2405 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/018.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/019.ent b/collects/tests/xml/clark-tests/valid/not-sa/019.ent new file mode 100644 index 0000000000..d18201a98b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/019.ent @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/019.xml b/collects/tests/xml/clark-tests/valid/not-sa/019.xml new file mode 100644 index 0000000000..b7a18faba0 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/019.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/020.ent b/collects/tests/xml/clark-tests/valid/not-sa/020.ent new file mode 100644 index 0000000000..815291c6d2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/020.ent @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/020.xml b/collects/tests/xml/clark-tests/valid/not-sa/020.xml new file mode 100644 index 0000000000..d70892f7ad --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/020.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/021.ent b/collects/tests/xml/clark-tests/valid/not-sa/021.ent new file mode 100644 index 0000000000..9f8f2afd2b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/021.ent @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/021.xml b/collects/tests/xml/clark-tests/valid/not-sa/021.xml new file mode 100644 index 0000000000..70c28730db --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/021.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/022.ent b/collects/tests/xml/clark-tests/valid/not-sa/022.ent new file mode 100644 index 0000000000..26f2d8beb2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/022.ent @@ -0,0 +1,3 @@ + + + ]]> diff --git a/collects/tests/xml/clark-tests/valid/not-sa/022.xml b/collects/tests/xml/clark-tests/valid/not-sa/022.xml new file mode 100644 index 0000000000..b639f2551c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/022.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/023.ent b/collects/tests/xml/clark-tests/valid/not-sa/023.ent new file mode 100644 index 0000000000..e3268819f7 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/023.ent @@ -0,0 +1,5 @@ + + + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/023.xml b/collects/tests/xml/clark-tests/valid/not-sa/023.xml new file mode 100644 index 0000000000..1c2484b70b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/023.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/024.ent b/collects/tests/xml/clark-tests/valid/not-sa/024.ent new file mode 100644 index 0000000000..aa6d0eccac --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/024.ent @@ -0,0 +1,4 @@ + + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/024.xml b/collects/tests/xml/clark-tests/valid/not-sa/024.xml new file mode 100644 index 0000000000..96e1ecb61b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/024.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/025.ent b/collects/tests/xml/clark-tests/valid/not-sa/025.ent new file mode 100644 index 0000000000..389d259eb1 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/025.ent @@ -0,0 +1,5 @@ + + + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/025.xml b/collects/tests/xml/clark-tests/valid/not-sa/025.xml new file mode 100644 index 0000000000..8fdbc14c47 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/025.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/026.ent b/collects/tests/xml/clark-tests/valid/not-sa/026.ent new file mode 100644 index 0000000000..bdc93af639 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/026.ent @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/026.xml b/collects/tests/xml/clark-tests/valid/not-sa/026.xml new file mode 100644 index 0000000000..7b109c0913 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/026.xml @@ -0,0 +1,7 @@ + + +%e; + +]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/027.ent b/collects/tests/xml/clark-tests/valid/not-sa/027.ent new file mode 100644 index 0000000000..712cce3700 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/027.ent @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/027.xml b/collects/tests/xml/clark-tests/valid/not-sa/027.xml new file mode 100644 index 0000000000..d0c8c7abb5 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/027.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/028.ent b/collects/tests/xml/clark-tests/valid/not-sa/028.ent new file mode 100644 index 0000000000..ac249d7b2c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/028.ent @@ -0,0 +1,2 @@ + +]]> diff --git a/collects/tests/xml/clark-tests/valid/not-sa/028.xml b/collects/tests/xml/clark-tests/valid/not-sa/028.xml new file mode 100644 index 0000000000..50e5248cbf --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/028.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/029.ent b/collects/tests/xml/clark-tests/valid/not-sa/029.ent new file mode 100644 index 0000000000..df94df5560 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/029.ent @@ -0,0 +1,3 @@ + +]]> + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/029.xml b/collects/tests/xml/clark-tests/valid/not-sa/029.xml new file mode 100644 index 0000000000..07e226c1d7 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/029.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/030.ent b/collects/tests/xml/clark-tests/valid/not-sa/030.ent new file mode 100644 index 0000000000..e3864460df --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/030.ent @@ -0,0 +1,3 @@ + + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/030.xml b/collects/tests/xml/clark-tests/valid/not-sa/030.xml new file mode 100644 index 0000000000..01fc2be4ca --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/030.xml @@ -0,0 +1,2 @@ + + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/031-1.ent b/collects/tests/xml/clark-tests/valid/not-sa/031-1.ent new file mode 100644 index 0000000000..f7f94ab152 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/031-1.ent @@ -0,0 +1,3 @@ + + +"> diff --git a/collects/tests/xml/clark-tests/valid/not-sa/031-2.ent b/collects/tests/xml/clark-tests/valid/not-sa/031-2.ent new file mode 100644 index 0000000000..bef50b1f38 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/031-2.ent @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/valid/not-sa/031.xml b/collects/tests/xml/clark-tests/valid/not-sa/031.xml new file mode 100644 index 0000000000..c3fe5fca71 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/031.xml @@ -0,0 +1,2 @@ + +&e; diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/001.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/001.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/001.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/002.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/002.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/002.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/003.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/003.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/003.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/004.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/004.xml new file mode 100644 index 0000000000..bdc39e2224 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/004.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/005.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/005.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/005.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/006.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/006.xml new file mode 100644 index 0000000000..d07627d7a3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/006.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/007.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/007.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/007.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/008.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/008.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/008.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/009.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/009.xml new file mode 100644 index 0000000000..7293fb63dc --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/009.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/010.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/010.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/010.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/011.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/011.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/011.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/012.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/012.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/012.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/013.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/013.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/013.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/014.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/014.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/014.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/015.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/015.xml new file mode 100644 index 0000000000..131a32fe69 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/015.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/016.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/016.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/016.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/017.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/017.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/017.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/018.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/018.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/018.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/019.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/019.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/019.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/020.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/020.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/020.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/021.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/021.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/021.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/022.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/022.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/022.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/023.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/023.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/023.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/024.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/024.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/024.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/025.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/025.xml new file mode 100644 index 0000000000..eb3f9674e8 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/025.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/026.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/026.xml new file mode 100644 index 0000000000..71c02026e4 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/026.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/027.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/027.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/027.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/028.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/028.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/028.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/029.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/029.xml new file mode 100644 index 0000000000..7ac8b2b89d --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/029.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/030.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/030.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/030.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/not-sa/out/031.xml b/collects/tests/xml/clark-tests/valid/not-sa/out/031.xml new file mode 100644 index 0000000000..03a6c3f9cd --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/not-sa/out/031.xml @@ -0,0 +1 @@ +<!ATTLIST doc a1 CDATA "v1"> \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/001.xml b/collects/tests/xml/clark-tests/valid/sa/001.xml new file mode 100644 index 0000000000..7fbef49502 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/001.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/002.xml b/collects/tests/xml/clark-tests/valid/sa/002.xml new file mode 100644 index 0000000000..2e3f1d81dd --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/002.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/003.xml b/collects/tests/xml/clark-tests/valid/sa/003.xml new file mode 100644 index 0000000000..c841b81784 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/003.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/004.xml b/collects/tests/xml/clark-tests/valid/sa/004.xml new file mode 100644 index 0000000000..a9c5756933 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/004.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/005.xml b/collects/tests/xml/clark-tests/valid/sa/005.xml new file mode 100644 index 0000000000..b069efe727 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/005.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/006.xml b/collects/tests/xml/clark-tests/valid/sa/006.xml new file mode 100644 index 0000000000..39a346342f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/006.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/007.xml b/collects/tests/xml/clark-tests/valid/sa/007.xml new file mode 100644 index 0000000000..cc3dc53166 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/007.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/008.xml b/collects/tests/xml/clark-tests/valid/sa/008.xml new file mode 100644 index 0000000000..b3370eb1cc --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/008.xml @@ -0,0 +1,4 @@ + +]> +&<>"' diff --git a/collects/tests/xml/clark-tests/valid/sa/009.xml b/collects/tests/xml/clark-tests/valid/sa/009.xml new file mode 100644 index 0000000000..0fa183eccf --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/009.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/010.xml b/collects/tests/xml/clark-tests/valid/sa/010.xml new file mode 100644 index 0000000000..eb64d18590 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/010.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/011.xml b/collects/tests/xml/clark-tests/valid/sa/011.xml new file mode 100644 index 0000000000..4cac44b4e4 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/011.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/012.xml b/collects/tests/xml/clark-tests/valid/sa/012.xml new file mode 100644 index 0000000000..6ce2a3eae2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/012.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/013.xml b/collects/tests/xml/clark-tests/valid/sa/013.xml new file mode 100644 index 0000000000..2f4aae4e28 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/013.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/014.xml b/collects/tests/xml/clark-tests/valid/sa/014.xml new file mode 100644 index 0000000000..47f1f723e3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/014.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/015.xml b/collects/tests/xml/clark-tests/valid/sa/015.xml new file mode 100644 index 0000000000..861df8a610 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/015.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/016.xml b/collects/tests/xml/clark-tests/valid/sa/016.xml new file mode 100644 index 0000000000..66b1973c5d --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/016.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/017.xml b/collects/tests/xml/clark-tests/valid/sa/017.xml new file mode 100644 index 0000000000..827ba963bf --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/017.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/018.xml b/collects/tests/xml/clark-tests/valid/sa/018.xml new file mode 100644 index 0000000000..4570903fee --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/018.xml @@ -0,0 +1,4 @@ + +]> +]]> diff --git a/collects/tests/xml/clark-tests/valid/sa/019.xml b/collects/tests/xml/clark-tests/valid/sa/019.xml new file mode 100644 index 0000000000..3e6b74cbf2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/019.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/020.xml b/collects/tests/xml/clark-tests/valid/sa/020.xml new file mode 100644 index 0000000000..f749551a1b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/020.xml @@ -0,0 +1,4 @@ + +]> +]]]> diff --git a/collects/tests/xml/clark-tests/valid/sa/021.xml b/collects/tests/xml/clark-tests/valid/sa/021.xml new file mode 100644 index 0000000000..13dda8c8a5 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/021.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/022.xml b/collects/tests/xml/clark-tests/valid/sa/022.xml new file mode 100644 index 0000000000..41d300e950 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/022.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/023.xml b/collects/tests/xml/clark-tests/valid/sa/023.xml new file mode 100644 index 0000000000..3837b831ad --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/023.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/024.xml b/collects/tests/xml/clark-tests/valid/sa/024.xml new file mode 100644 index 0000000000..b0655c634c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/024.xml @@ -0,0 +1,6 @@ + + +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/025.xml b/collects/tests/xml/clark-tests/valid/sa/025.xml new file mode 100644 index 0000000000..ed01f36d89 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/025.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/026.xml b/collects/tests/xml/clark-tests/valid/sa/026.xml new file mode 100644 index 0000000000..1ba033c1a7 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/026.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/027.xml b/collects/tests/xml/clark-tests/valid/sa/027.xml new file mode 100644 index 0000000000..ee02439051 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/027.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/028.xml b/collects/tests/xml/clark-tests/valid/sa/028.xml new file mode 100644 index 0000000000..3d95747913 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/028.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/029.xml b/collects/tests/xml/clark-tests/valid/sa/029.xml new file mode 100644 index 0000000000..909f6ff712 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/029.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/030.xml b/collects/tests/xml/clark-tests/valid/sa/030.xml new file mode 100644 index 0000000000..3a7ddaa716 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/030.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/031.xml b/collects/tests/xml/clark-tests/valid/sa/031.xml new file mode 100644 index 0000000000..a58e05867f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/031.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/032.xml b/collects/tests/xml/clark-tests/valid/sa/032.xml new file mode 100644 index 0000000000..be55c8d721 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/032.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/033.xml b/collects/tests/xml/clark-tests/valid/sa/033.xml new file mode 100644 index 0000000000..a3f9053868 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/033.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/034.xml b/collects/tests/xml/clark-tests/valid/sa/034.xml new file mode 100644 index 0000000000..7d52f31c0e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/034.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/035.xml b/collects/tests/xml/clark-tests/valid/sa/035.xml new file mode 100644 index 0000000000..f109a8b782 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/035.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/036.xml b/collects/tests/xml/clark-tests/valid/sa/036.xml new file mode 100644 index 0000000000..8ab2b3fb16 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/036.xml @@ -0,0 +1,5 @@ + +]> + + diff --git a/collects/tests/xml/clark-tests/valid/sa/037.xml b/collects/tests/xml/clark-tests/valid/sa/037.xml new file mode 100644 index 0000000000..f9b2113940 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/037.xml @@ -0,0 +1,6 @@ + +]> + + + diff --git a/collects/tests/xml/clark-tests/valid/sa/038.xml b/collects/tests/xml/clark-tests/valid/sa/038.xml new file mode 100644 index 0000000000..d14f41bfe2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/038.xml @@ -0,0 +1,6 @@ + + +]> + + diff --git a/collects/tests/xml/clark-tests/valid/sa/039.xml b/collects/tests/xml/clark-tests/valid/sa/039.xml new file mode 100644 index 0000000000..0897316e46 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/039.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/040.xml b/collects/tests/xml/clark-tests/valid/sa/040.xml new file mode 100644 index 0000000000..12c419b65b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/040.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/041.xml b/collects/tests/xml/clark-tests/valid/sa/041.xml new file mode 100644 index 0000000000..a59f536277 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/041.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/042.xml b/collects/tests/xml/clark-tests/valid/sa/042.xml new file mode 100644 index 0000000000..5d7c650944 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/042.xml @@ -0,0 +1,4 @@ + +]> +A diff --git a/collects/tests/xml/clark-tests/valid/sa/043.xml b/collects/tests/xml/clark-tests/valid/sa/043.xml new file mode 100644 index 0000000000..a8095dfe28 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/043.xml @@ -0,0 +1,6 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/044.xml b/collects/tests/xml/clark-tests/valid/sa/044.xml new file mode 100644 index 0000000000..bee1d23e1a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/044.xml @@ -0,0 +1,10 @@ + + + +]> + + + + + diff --git a/collects/tests/xml/clark-tests/valid/sa/045.xml b/collects/tests/xml/clark-tests/valid/sa/045.xml new file mode 100644 index 0000000000..e2567f532d --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/045.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/046.xml b/collects/tests/xml/clark-tests/valid/sa/046.xml new file mode 100644 index 0000000000..c50a2846f9 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/046.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/047.xml b/collects/tests/xml/clark-tests/valid/sa/047.xml new file mode 100644 index 0000000000..a4c688cf1a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/047.xml @@ -0,0 +1,5 @@ + +]> +X +Y diff --git a/collects/tests/xml/clark-tests/valid/sa/048.xml b/collects/tests/xml/clark-tests/valid/sa/048.xml new file mode 100644 index 0000000000..c6b2dedbba --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/048.xml @@ -0,0 +1,4 @@ + +]> +] diff --git a/collects/tests/xml/clark-tests/valid/sa/049.xml b/collects/tests/xml/clark-tests/valid/sa/049.xml new file mode 100644 index 0000000000000000000000000000000000000000..c3cc797b5954881cc794f6720674a8bfa13aacbe GIT binary patch literal 124 zcmezW&xS#f!G*z}!I>e1A(A10!IeRQA%!8IAsI+VGw?ESF@RLKGWY^1d2N{XfoJ=^~6GH8>m@!42yy0=)-v+a{e1A(A10!IeRQA%!8IAsI+VGw?ESF@RLKGWY^1d2N{XfoJ=^~6GH8>m@!3=Vu8e2RQpd_H_O4Ek_Ukof>egAywM literal 0 HcmV?d00001 diff --git a/collects/tests/xml/clark-tests/valid/sa/051.xml b/collects/tests/xml/clark-tests/valid/sa/051.xml new file mode 100644 index 0000000000000000000000000000000000000000..7ae8f6c73a4b47ec18492ebefed16c63f5f5ef22 GIT binary patch literal 140 zcmezW&xS#f!G*z}!I>e1A(A10!IeRQ!GVv1PmxcH&xcQeA)0}gfr|m8%9X(fh<$&nXgECOJGtewYpsXW +]> +𐀀􏿽 diff --git a/collects/tests/xml/clark-tests/valid/sa/053.xml b/collects/tests/xml/clark-tests/valid/sa/053.xml new file mode 100644 index 0000000000..0d88f28718 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/053.xml @@ -0,0 +1,6 @@ +"> + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/054.xml b/collects/tests/xml/clark-tests/valid/sa/054.xml new file mode 100644 index 0000000000..5d1c88b946 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/054.xml @@ -0,0 +1,10 @@ + +]> + + + + + diff --git a/collects/tests/xml/clark-tests/valid/sa/055.xml b/collects/tests/xml/clark-tests/valid/sa/055.xml new file mode 100644 index 0000000000..da0292c5bc --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/055.xml @@ -0,0 +1,5 @@ + +]> + + diff --git a/collects/tests/xml/clark-tests/valid/sa/056.xml b/collects/tests/xml/clark-tests/valid/sa/056.xml new file mode 100644 index 0000000000..144871b2a3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/056.xml @@ -0,0 +1,4 @@ + +]> +A diff --git a/collects/tests/xml/clark-tests/valid/sa/057.xml b/collects/tests/xml/clark-tests/valid/sa/057.xml new file mode 100644 index 0000000000..c1ac849ed1 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/057.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/058.xml b/collects/tests/xml/clark-tests/valid/sa/058.xml new file mode 100644 index 0000000000..2ff23b233f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/058.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/059.xml b/collects/tests/xml/clark-tests/valid/sa/059.xml new file mode 100644 index 0000000000..2171480ecf --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/059.xml @@ -0,0 +1,10 @@ + + + +]> + + + + + diff --git a/collects/tests/xml/clark-tests/valid/sa/060.xml b/collects/tests/xml/clark-tests/valid/sa/060.xml new file mode 100644 index 0000000000..6cd6b4386b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/060.xml @@ -0,0 +1,4 @@ + +]> +X Y diff --git a/collects/tests/xml/clark-tests/valid/sa/061.xml b/collects/tests/xml/clark-tests/valid/sa/061.xml new file mode 100644 index 0000000000..bbdc152492 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/061.xml @@ -0,0 +1,4 @@ + +]> +£ diff --git a/collects/tests/xml/clark-tests/valid/sa/062.xml b/collects/tests/xml/clark-tests/valid/sa/062.xml new file mode 100644 index 0000000000..f4ba53090a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/062.xml @@ -0,0 +1,4 @@ + +]> +เจมส์ diff --git a/collects/tests/xml/clark-tests/valid/sa/063.xml b/collects/tests/xml/clark-tests/valid/sa/063.xml new file mode 100644 index 0000000000..9668f2da73 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/063.xml @@ -0,0 +1,4 @@ + +]> +<เจมส์> diff --git a/collects/tests/xml/clark-tests/valid/sa/064.xml b/collects/tests/xml/clark-tests/valid/sa/064.xml new file mode 100644 index 0000000000..74a97aa431 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/064.xml @@ -0,0 +1,4 @@ + +]> +𐀀􏿽 diff --git a/collects/tests/xml/clark-tests/valid/sa/065.xml b/collects/tests/xml/clark-tests/valid/sa/065.xml new file mode 100644 index 0000000000..f708f2bc17 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/065.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/066.xml b/collects/tests/xml/clark-tests/valid/sa/066.xml new file mode 100644 index 0000000000..a27340b9a7 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/066.xml @@ -0,0 +1,7 @@ + + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/067.xml b/collects/tests/xml/clark-tests/valid/sa/067.xml new file mode 100644 index 0000000000..a0ccf772a5 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/067.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/068.xml b/collects/tests/xml/clark-tests/valid/sa/068.xml new file mode 100644 index 0000000000..8ed806b9a3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/068.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/069.xml b/collects/tests/xml/clark-tests/valid/sa/069.xml new file mode 100644 index 0000000000..2437f60530 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/069.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/070.xml b/collects/tests/xml/clark-tests/valid/sa/070.xml new file mode 100644 index 0000000000..eef097df76 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/070.xml @@ -0,0 +1,5 @@ +"> +%e; +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/071.xml b/collects/tests/xml/clark-tests/valid/sa/071.xml new file mode 100644 index 0000000000..ebfba230a4 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/071.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/072.xml b/collects/tests/xml/clark-tests/valid/sa/072.xml new file mode 100644 index 0000000000..6ef39dc49e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/072.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/073.xml b/collects/tests/xml/clark-tests/valid/sa/073.xml new file mode 100644 index 0000000000..217476d9a9 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/073.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/074.xml b/collects/tests/xml/clark-tests/valid/sa/074.xml new file mode 100644 index 0000000000..8b2354ff73 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/074.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/075.xml b/collects/tests/xml/clark-tests/valid/sa/075.xml new file mode 100644 index 0000000000..33c012441a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/075.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/076.xml b/collects/tests/xml/clark-tests/valid/sa/076.xml new file mode 100644 index 0000000000..65b731cf6d --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/076.xml @@ -0,0 +1,7 @@ + + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/077.xml b/collects/tests/xml/clark-tests/valid/sa/077.xml new file mode 100644 index 0000000000..e5f301eac8 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/077.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/078.xml b/collects/tests/xml/clark-tests/valid/sa/078.xml new file mode 100644 index 0000000000..b31f40f94e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/078.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/079.xml b/collects/tests/xml/clark-tests/valid/sa/079.xml new file mode 100644 index 0000000000..a3290d6cbb --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/079.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/080.xml b/collects/tests/xml/clark-tests/valid/sa/080.xml new file mode 100644 index 0000000000..3208fa9aa5 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/080.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/081.xml b/collects/tests/xml/clark-tests/valid/sa/081.xml new file mode 100644 index 0000000000..51ee1a375c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/081.xml @@ -0,0 +1,7 @@ + + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/082.xml b/collects/tests/xml/clark-tests/valid/sa/082.xml new file mode 100644 index 0000000000..d5245ac51a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/082.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/083.xml b/collects/tests/xml/clark-tests/valid/sa/083.xml new file mode 100644 index 0000000000..937cfc0bdd --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/083.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/084.xml b/collects/tests/xml/clark-tests/valid/sa/084.xml new file mode 100644 index 0000000000..82760767aa --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/084.xml @@ -0,0 +1 @@ +]> diff --git a/collects/tests/xml/clark-tests/valid/sa/085.xml b/collects/tests/xml/clark-tests/valid/sa/085.xml new file mode 100644 index 0000000000..cf5834f2a5 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/085.xml @@ -0,0 +1,6 @@ + +"> + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/086.xml b/collects/tests/xml/clark-tests/valid/sa/086.xml new file mode 100644 index 0000000000..bbc3080db6 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/086.xml @@ -0,0 +1,6 @@ + + +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/087.xml b/collects/tests/xml/clark-tests/valid/sa/087.xml new file mode 100644 index 0000000000..34797a67d7 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/087.xml @@ -0,0 +1,6 @@ + + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/088.xml b/collects/tests/xml/clark-tests/valid/sa/088.xml new file mode 100644 index 0000000000..f97d96848d --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/088.xml @@ -0,0 +1,5 @@ + +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/089.xml b/collects/tests/xml/clark-tests/valid/sa/089.xml new file mode 100644 index 0000000000..2d80c8f3fb --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/089.xml @@ -0,0 +1,5 @@ + + +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/090.xml b/collects/tests/xml/clark-tests/valid/sa/090.xml new file mode 100644 index 0000000000..c392c96084 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/090.xml @@ -0,0 +1,7 @@ + + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/091.xml b/collects/tests/xml/clark-tests/valid/sa/091.xml new file mode 100644 index 0000000000..7343d0f795 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/091.xml @@ -0,0 +1,7 @@ + + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/092.xml b/collects/tests/xml/clark-tests/valid/sa/092.xml new file mode 100644 index 0000000000..627b74ecdf --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/092.xml @@ -0,0 +1,10 @@ + + +]> + + + + + + diff --git a/collects/tests/xml/clark-tests/valid/sa/093.xml b/collects/tests/xml/clark-tests/valid/sa/093.xml new file mode 100644 index 0000000000..968acb628f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/093.xml @@ -0,0 +1,5 @@ + +]> + + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/094.xml b/collects/tests/xml/clark-tests/valid/sa/094.xml new file mode 100644 index 0000000000..5726e7db6f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/094.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/095.xml b/collects/tests/xml/clark-tests/valid/sa/095.xml new file mode 100644 index 0000000000..1fe69596da --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/095.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/096.xml b/collects/tests/xml/clark-tests/valid/sa/096.xml new file mode 100644 index 0000000000..a6f8f43620 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/096.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/097.ent b/collects/tests/xml/clark-tests/valid/sa/097.ent new file mode 100644 index 0000000000..e06554ace2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/097.ent @@ -0,0 +1 @@ + diff --git a/collects/tests/xml/clark-tests/valid/sa/097.xml b/collects/tests/xml/clark-tests/valid/sa/097.xml new file mode 100644 index 0000000000..c606afa97f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/097.xml @@ -0,0 +1,8 @@ + + + +%e; + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/098.xml b/collects/tests/xml/clark-tests/valid/sa/098.xml new file mode 100644 index 0000000000..33a64ce5ae --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/098.xml @@ -0,0 +1,5 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/099.xml b/collects/tests/xml/clark-tests/valid/sa/099.xml new file mode 100644 index 0000000000..1b7214a137 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/099.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/100.xml b/collects/tests/xml/clark-tests/valid/sa/100.xml new file mode 100644 index 0000000000..5b839e76bc --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/100.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/101.xml b/collects/tests/xml/clark-tests/valid/sa/101.xml new file mode 100644 index 0000000000..f464484bf5 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/101.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/102.xml b/collects/tests/xml/clark-tests/valid/sa/102.xml new file mode 100644 index 0000000000..f239ff5fee --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/102.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/103.xml b/collects/tests/xml/clark-tests/valid/sa/103.xml new file mode 100644 index 0000000000..1dbbd5bb7c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/103.xml @@ -0,0 +1,4 @@ + +]> +<doc> diff --git a/collects/tests/xml/clark-tests/valid/sa/104.xml b/collects/tests/xml/clark-tests/valid/sa/104.xml new file mode 100644 index 0000000000..666f43de0f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/104.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/105.xml b/collects/tests/xml/clark-tests/valid/sa/105.xml new file mode 100644 index 0000000000..6b3af2b847 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/105.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/106.xml b/collects/tests/xml/clark-tests/valid/sa/106.xml new file mode 100644 index 0000000000..8757c0a5ae --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/106.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/107.xml b/collects/tests/xml/clark-tests/valid/sa/107.xml new file mode 100644 index 0000000000..3d2c2566a7 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/107.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/108.xml b/collects/tests/xml/clark-tests/valid/sa/108.xml new file mode 100644 index 0000000000..e919bf229a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/108.xml @@ -0,0 +1,7 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/109.xml b/collects/tests/xml/clark-tests/valid/sa/109.xml new file mode 100644 index 0000000000..33fa38e13b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/109.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/110.xml b/collects/tests/xml/clark-tests/valid/sa/110.xml new file mode 100644 index 0000000000..0c61c65119 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/110.xml @@ -0,0 +1,6 @@ + + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/111.xml b/collects/tests/xml/clark-tests/valid/sa/111.xml new file mode 100644 index 0000000000..cb56f264b0 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/111.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/112.xml b/collects/tests/xml/clark-tests/valid/sa/112.xml new file mode 100644 index 0000000000..27b6a4c793 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/112.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/113.xml b/collects/tests/xml/clark-tests/valid/sa/113.xml new file mode 100644 index 0000000000..d2edd0f01d --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/113.xml @@ -0,0 +1,5 @@ + + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/114.xml b/collects/tests/xml/clark-tests/valid/sa/114.xml new file mode 100644 index 0000000000..52e207096d --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/114.xml @@ -0,0 +1,5 @@ + +"> +]> +&e; diff --git a/collects/tests/xml/clark-tests/valid/sa/115.xml b/collects/tests/xml/clark-tests/valid/sa/115.xml new file mode 100644 index 0000000000..d939a67010 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/115.xml @@ -0,0 +1,6 @@ + + + +]> +&e1; diff --git a/collects/tests/xml/clark-tests/valid/sa/116.xml b/collects/tests/xml/clark-tests/valid/sa/116.xml new file mode 100644 index 0000000000..55ab49620b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/116.xml @@ -0,0 +1,5 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/117.xml b/collects/tests/xml/clark-tests/valid/sa/117.xml new file mode 100644 index 0000000000..e4f02b14c8 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/117.xml @@ -0,0 +1,5 @@ + + +]> +] diff --git a/collects/tests/xml/clark-tests/valid/sa/118.xml b/collects/tests/xml/clark-tests/valid/sa/118.xml new file mode 100644 index 0000000000..fba6c44668 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/118.xml @@ -0,0 +1,5 @@ + + +]> +] diff --git a/collects/tests/xml/clark-tests/valid/sa/119.xml b/collects/tests/xml/clark-tests/valid/sa/119.xml new file mode 100644 index 0000000000..876e74730c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/119.xml @@ -0,0 +1,4 @@ + +]> + diff --git a/collects/tests/xml/clark-tests/valid/sa/out/001.xml b/collects/tests/xml/clark-tests/valid/sa/out/001.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/001.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/002.xml b/collects/tests/xml/clark-tests/valid/sa/out/002.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/002.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/003.xml b/collects/tests/xml/clark-tests/valid/sa/out/003.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/003.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/004.xml b/collects/tests/xml/clark-tests/valid/sa/out/004.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/004.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/005.xml b/collects/tests/xml/clark-tests/valid/sa/out/005.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/005.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/006.xml b/collects/tests/xml/clark-tests/valid/sa/out/006.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/006.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/007.xml b/collects/tests/xml/clark-tests/valid/sa/out/007.xml new file mode 100644 index 0000000000..97cf3e3b86 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/007.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/008.xml b/collects/tests/xml/clark-tests/valid/sa/out/008.xml new file mode 100644 index 0000000000..3ea232c21a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/008.xml @@ -0,0 +1 @@ +&<>"' \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/009.xml b/collects/tests/xml/clark-tests/valid/sa/out/009.xml new file mode 100644 index 0000000000..97cf3e3b86 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/009.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/010.xml b/collects/tests/xml/clark-tests/valid/sa/out/010.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/010.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/011.xml b/collects/tests/xml/clark-tests/valid/sa/out/011.xml new file mode 100644 index 0000000000..7293fb63dc --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/011.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/012.xml b/collects/tests/xml/clark-tests/valid/sa/out/012.xml new file mode 100644 index 0000000000..5a0c9831ae --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/012.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/013.xml b/collects/tests/xml/clark-tests/valid/sa/out/013.xml new file mode 100644 index 0000000000..c9c7ec5da8 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/013.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/014.xml b/collects/tests/xml/clark-tests/valid/sa/out/014.xml new file mode 100644 index 0000000000..ac6b28f97a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/014.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/015.xml b/collects/tests/xml/clark-tests/valid/sa/out/015.xml new file mode 100644 index 0000000000..8e216eb99b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/015.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/016.xml b/collects/tests/xml/clark-tests/valid/sa/out/016.xml new file mode 100644 index 0000000000..4fc76928b2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/016.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/017.xml b/collects/tests/xml/clark-tests/valid/sa/out/017.xml new file mode 100644 index 0000000000..3b9a2f8d4e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/017.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/018.xml b/collects/tests/xml/clark-tests/valid/sa/out/018.xml new file mode 100644 index 0000000000..a5471011df --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/018.xml @@ -0,0 +1 @@ +<foo> \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/019.xml b/collects/tests/xml/clark-tests/valid/sa/out/019.xml new file mode 100644 index 0000000000..05d4e2fcf9 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/019.xml @@ -0,0 +1 @@ +<& \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/020.xml b/collects/tests/xml/clark-tests/valid/sa/out/020.xml new file mode 100644 index 0000000000..95ae08a12e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/020.xml @@ -0,0 +1 @@ +<&]>] \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/021.xml b/collects/tests/xml/clark-tests/valid/sa/out/021.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/021.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/022.xml b/collects/tests/xml/clark-tests/valid/sa/out/022.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/022.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/023.xml b/collects/tests/xml/clark-tests/valid/sa/out/023.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/023.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/024.xml b/collects/tests/xml/clark-tests/valid/sa/out/024.xml new file mode 100644 index 0000000000..a9aa2074ff --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/024.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/025.xml b/collects/tests/xml/clark-tests/valid/sa/out/025.xml new file mode 100644 index 0000000000..de0f566020 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/025.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/026.xml b/collects/tests/xml/clark-tests/valid/sa/out/026.xml new file mode 100644 index 0000000000..de0f566020 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/026.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/027.xml b/collects/tests/xml/clark-tests/valid/sa/out/027.xml new file mode 100644 index 0000000000..de0f566020 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/027.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/028.xml b/collects/tests/xml/clark-tests/valid/sa/out/028.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/028.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/029.xml b/collects/tests/xml/clark-tests/valid/sa/out/029.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/029.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/030.xml b/collects/tests/xml/clark-tests/valid/sa/out/030.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/030.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/031.xml b/collects/tests/xml/clark-tests/valid/sa/out/031.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/031.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/032.xml b/collects/tests/xml/clark-tests/valid/sa/out/032.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/032.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/033.xml b/collects/tests/xml/clark-tests/valid/sa/out/033.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/033.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/034.xml b/collects/tests/xml/clark-tests/valid/sa/out/034.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/034.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/035.xml b/collects/tests/xml/clark-tests/valid/sa/out/035.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/035.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/036.xml b/collects/tests/xml/clark-tests/valid/sa/out/036.xml new file mode 100644 index 0000000000..2bcfb06cf1 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/036.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/037.xml b/collects/tests/xml/clark-tests/valid/sa/out/037.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/037.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/038.xml b/collects/tests/xml/clark-tests/valid/sa/out/038.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/038.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/039.xml b/collects/tests/xml/clark-tests/valid/sa/out/039.xml new file mode 100644 index 0000000000..82d117d492 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/039.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/040.xml b/collects/tests/xml/clark-tests/valid/sa/out/040.xml new file mode 100644 index 0000000000..d79cfe1493 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/040.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/041.xml b/collects/tests/xml/clark-tests/valid/sa/out/041.xml new file mode 100644 index 0000000000..6f2cd5832e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/041.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/042.xml b/collects/tests/xml/clark-tests/valid/sa/out/042.xml new file mode 100644 index 0000000000..f683039a80 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/042.xml @@ -0,0 +1 @@ +A \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/043.xml b/collects/tests/xml/clark-tests/valid/sa/out/043.xml new file mode 100644 index 0000000000..e162b76504 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/043.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/044.xml b/collects/tests/xml/clark-tests/valid/sa/out/044.xml new file mode 100644 index 0000000000..78028b704b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/044.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/045.xml b/collects/tests/xml/clark-tests/valid/sa/out/045.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/045.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/046.xml b/collects/tests/xml/clark-tests/valid/sa/out/046.xml new file mode 100644 index 0000000000..7293fb63dc --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/046.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/047.xml b/collects/tests/xml/clark-tests/valid/sa/out/047.xml new file mode 100644 index 0000000000..b327ebd67f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/047.xml @@ -0,0 +1 @@ +X Y \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/048.xml b/collects/tests/xml/clark-tests/valid/sa/out/048.xml new file mode 100644 index 0000000000..ced7d02719 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/048.xml @@ -0,0 +1 @@ +] \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/049.xml b/collects/tests/xml/clark-tests/valid/sa/out/049.xml new file mode 100644 index 0000000000..7cc53f9ea0 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/049.xml @@ -0,0 +1 @@ +£ \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/050.xml b/collects/tests/xml/clark-tests/valid/sa/out/050.xml new file mode 100644 index 0000000000..33703c7925 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/050.xml @@ -0,0 +1 @@ +เจมส์ \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/051.xml b/collects/tests/xml/clark-tests/valid/sa/out/051.xml new file mode 100644 index 0000000000..cfeb5a5366 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/051.xml @@ -0,0 +1 @@ +<เจมส์> \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/052.xml b/collects/tests/xml/clark-tests/valid/sa/out/052.xml new file mode 100644 index 0000000000..f5a0484791 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/052.xml @@ -0,0 +1 @@ +𐀀􏿽 \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/053.xml b/collects/tests/xml/clark-tests/valid/sa/out/053.xml new file mode 100644 index 0000000000..c4083843d9 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/053.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/054.xml b/collects/tests/xml/clark-tests/valid/sa/out/054.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/054.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/055.xml b/collects/tests/xml/clark-tests/valid/sa/out/055.xml new file mode 100644 index 0000000000..82d117d492 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/055.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/056.xml b/collects/tests/xml/clark-tests/valid/sa/out/056.xml new file mode 100644 index 0000000000..f683039a80 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/056.xml @@ -0,0 +1 @@ +A \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/057.xml b/collects/tests/xml/clark-tests/valid/sa/out/057.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/057.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/058.xml b/collects/tests/xml/clark-tests/valid/sa/out/058.xml new file mode 100644 index 0000000000..f898cc8c98 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/058.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/059.xml b/collects/tests/xml/clark-tests/valid/sa/out/059.xml new file mode 100644 index 0000000000..78028b704b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/059.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/060.xml b/collects/tests/xml/clark-tests/valid/sa/out/060.xml new file mode 100644 index 0000000000..b327ebd67f --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/060.xml @@ -0,0 +1 @@ +X Y \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/061.xml b/collects/tests/xml/clark-tests/valid/sa/out/061.xml new file mode 100644 index 0000000000..7cc53f9ea0 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/061.xml @@ -0,0 +1 @@ +£ \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/062.xml b/collects/tests/xml/clark-tests/valid/sa/out/062.xml new file mode 100644 index 0000000000..33703c7925 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/062.xml @@ -0,0 +1 @@ +เจมส์ \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/063.xml b/collects/tests/xml/clark-tests/valid/sa/out/063.xml new file mode 100644 index 0000000000..cfeb5a5366 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/063.xml @@ -0,0 +1 @@ +<เจมส์> \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/064.xml b/collects/tests/xml/clark-tests/valid/sa/out/064.xml new file mode 100644 index 0000000000..f5a0484791 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/064.xml @@ -0,0 +1 @@ +𐀀􏿽 \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/065.xml b/collects/tests/xml/clark-tests/valid/sa/out/065.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/065.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/066.xml b/collects/tests/xml/clark-tests/valid/sa/out/066.xml new file mode 100644 index 0000000000..7597d31bf9 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/066.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/067.xml b/collects/tests/xml/clark-tests/valid/sa/out/067.xml new file mode 100644 index 0000000000..4bbdad45ed --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/067.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/068.xml b/collects/tests/xml/clark-tests/valid/sa/out/068.xml new file mode 100644 index 0000000000..4bbdad45ed --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/068.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/069.xml b/collects/tests/xml/clark-tests/valid/sa/out/069.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/069.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/070.xml b/collects/tests/xml/clark-tests/valid/sa/out/070.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/070.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/071.xml b/collects/tests/xml/clark-tests/valid/sa/out/071.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/071.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/072.xml b/collects/tests/xml/clark-tests/valid/sa/out/072.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/072.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/073.xml b/collects/tests/xml/clark-tests/valid/sa/out/073.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/073.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/074.xml b/collects/tests/xml/clark-tests/valid/sa/out/074.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/074.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/075.xml b/collects/tests/xml/clark-tests/valid/sa/out/075.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/075.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/076.xml b/collects/tests/xml/clark-tests/valid/sa/out/076.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/076.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/077.xml b/collects/tests/xml/clark-tests/valid/sa/out/077.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/077.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/078.xml b/collects/tests/xml/clark-tests/valid/sa/out/078.xml new file mode 100644 index 0000000000..fcab0cd7ff --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/078.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/079.xml b/collects/tests/xml/clark-tests/valid/sa/out/079.xml new file mode 100644 index 0000000000..fcab0cd7ff --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/079.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/080.xml b/collects/tests/xml/clark-tests/valid/sa/out/080.xml new file mode 100644 index 0000000000..fcab0cd7ff --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/080.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/081.xml b/collects/tests/xml/clark-tests/valid/sa/out/081.xml new file mode 100644 index 0000000000..e356e7e4db --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/081.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/082.xml b/collects/tests/xml/clark-tests/valid/sa/out/082.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/082.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/083.xml b/collects/tests/xml/clark-tests/valid/sa/out/083.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/083.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/084.xml b/collects/tests/xml/clark-tests/valid/sa/out/084.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/084.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/085.xml b/collects/tests/xml/clark-tests/valid/sa/out/085.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/085.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/086.xml b/collects/tests/xml/clark-tests/valid/sa/out/086.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/086.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/087.xml b/collects/tests/xml/clark-tests/valid/sa/out/087.xml new file mode 100644 index 0000000000..a9aa2074ff --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/087.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/088.xml b/collects/tests/xml/clark-tests/valid/sa/out/088.xml new file mode 100644 index 0000000000..a5471011df --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/088.xml @@ -0,0 +1 @@ +<foo> \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/089.xml b/collects/tests/xml/clark-tests/valid/sa/out/089.xml new file mode 100644 index 0000000000..e01d86e8d3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/089.xml @@ -0,0 +1 @@ +𐀀􏿽􏿿 \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/090.xml b/collects/tests/xml/clark-tests/valid/sa/out/090.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/090.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/091.xml b/collects/tests/xml/clark-tests/valid/sa/out/091.xml new file mode 100644 index 0000000000..dd3bbedf74 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/091.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/092.xml b/collects/tests/xml/clark-tests/valid/sa/out/092.xml new file mode 100644 index 0000000000..87269f79d9 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/092.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/093.xml b/collects/tests/xml/clark-tests/valid/sa/out/093.xml new file mode 100644 index 0000000000..631bfde91e --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/093.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/094.xml b/collects/tests/xml/clark-tests/valid/sa/out/094.xml new file mode 100644 index 0000000000..636ab4729a --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/094.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/095.xml b/collects/tests/xml/clark-tests/valid/sa/out/095.xml new file mode 100644 index 0000000000..a20706ee01 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/095.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/096.xml b/collects/tests/xml/clark-tests/valid/sa/out/096.xml new file mode 100644 index 0000000000..f898cc8c98 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/096.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/097.xml b/collects/tests/xml/clark-tests/valid/sa/out/097.xml new file mode 100644 index 0000000000..e05cfe6c31 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/097.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/098.xml b/collects/tests/xml/clark-tests/valid/sa/out/098.xml new file mode 100644 index 0000000000..f6408de9b8 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/098.xml @@ -0,0 +1,2 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/099.xml b/collects/tests/xml/clark-tests/valid/sa/out/099.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/099.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/100.xml b/collects/tests/xml/clark-tests/valid/sa/out/100.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/100.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/101.xml b/collects/tests/xml/clark-tests/valid/sa/out/101.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/101.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/102.xml b/collects/tests/xml/clark-tests/valid/sa/out/102.xml new file mode 100644 index 0000000000..6e66b8da21 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/102.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/103.xml b/collects/tests/xml/clark-tests/valid/sa/out/103.xml new file mode 100644 index 0000000000..96495d45c3 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/103.xml @@ -0,0 +1 @@ +<doc> \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/104.xml b/collects/tests/xml/clark-tests/valid/sa/out/104.xml new file mode 100644 index 0000000000..cc3def3336 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/104.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/105.xml b/collects/tests/xml/clark-tests/valid/sa/out/105.xml new file mode 100644 index 0000000000..5aed3d613b --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/105.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/106.xml b/collects/tests/xml/clark-tests/valid/sa/out/106.xml new file mode 100644 index 0000000000..1197d2ff9c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/106.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/107.xml b/collects/tests/xml/clark-tests/valid/sa/out/107.xml new file mode 100644 index 0000000000..288f23cdf2 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/107.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/108.xml b/collects/tests/xml/clark-tests/valid/sa/out/108.xml new file mode 100644 index 0000000000..cc3def3336 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/108.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/109.xml b/collects/tests/xml/clark-tests/valid/sa/out/109.xml new file mode 100644 index 0000000000..c43bdf9b9c --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/109.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/110.xml b/collects/tests/xml/clark-tests/valid/sa/out/110.xml new file mode 100644 index 0000000000..a92237b4ec --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/110.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/111.xml b/collects/tests/xml/clark-tests/valid/sa/out/111.xml new file mode 100644 index 0000000000..cc3def3336 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/111.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/112.xml b/collects/tests/xml/clark-tests/valid/sa/out/112.xml new file mode 100644 index 0000000000..c82f47bca8 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/112.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/113.xml b/collects/tests/xml/clark-tests/valid/sa/out/113.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/113.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/114.xml b/collects/tests/xml/clark-tests/valid/sa/out/114.xml new file mode 100644 index 0000000000..8e0722abad --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/114.xml @@ -0,0 +1 @@ +&foo; \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/115.xml b/collects/tests/xml/clark-tests/valid/sa/out/115.xml new file mode 100644 index 0000000000..682b8140ec --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/115.xml @@ -0,0 +1 @@ +v \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/116.xml b/collects/tests/xml/clark-tests/valid/sa/out/116.xml new file mode 100644 index 0000000000..a79dff65fd --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/116.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/117.xml b/collects/tests/xml/clark-tests/valid/sa/out/117.xml new file mode 100644 index 0000000000..ced7d02719 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/117.xml @@ -0,0 +1 @@ +] \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/118.xml b/collects/tests/xml/clark-tests/valid/sa/out/118.xml new file mode 100644 index 0000000000..31e37a9398 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/118.xml @@ -0,0 +1 @@ +]] \ No newline at end of file diff --git a/collects/tests/xml/clark-tests/valid/sa/out/119.xml b/collects/tests/xml/clark-tests/valid/sa/out/119.xml new file mode 100644 index 0000000000..7e8f183484 --- /dev/null +++ b/collects/tests/xml/clark-tests/valid/sa/out/119.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/collects/tests/xml/test-clark.ss b/collects/tests/xml/test-clark.ss new file mode 100644 index 0000000000..eeffd6ab2a --- /dev/null +++ b/collects/tests/xml/test-clark.ss @@ -0,0 +1,90 @@ +#lang scheme +(require (planet schematics/schemeunit:3) + (planet schematics/schemeunit:3/base) + (planet schematics/schemeunit:3/test-case) + (planet schematics/schemeunit:3/check) + (planet schematics/schemeunit:3/test-suite) + (planet schematics/schemeunit:3/text-ui) + xml + scheme/runtime-path) + +(define (validate-xml? xml) + (error 'validate-xml? "Not implemented")) +(define (well-formed-xml? xml) + (error 'well-formed-xml? "Not implemented")) + +(define (read-xml/file f) + (with-input-from-file f + (lambda () (read-xml)))) +(define (dir->test-suite d name path->test-case) + (make-schemeunit-test-suite + name + (parameterize + ([current-test-case-around test-suite-test-case-around] + [current-check-around test-suite-check-around]) + (map (lambda (p) + (path->test-case (build-path d p))) + (filter (lambda (p) + (define ext (filename-extension p)) + (and ext (bytes=? #"xml" ext))) + (directory-list d)))) + void + void)) + +(define (not-wf-dir->test-suite d) + (define (path->test-case f) + (test-not-false + (path->string f) + (with-handlers ([exn:xml? (lambda _ #t)]) + (not (well-formed-xml? (read-xml/file f)))))) + (test-suite + "Not Well-Formed" + (dir->test-suite + (build-path d "sa") "Stand-alone" + path->test-case) + (dir->test-suite + (build-path d "ext-sa") "External Stand-alone" + path->test-case) + (dir->test-suite + (build-path d "not-sa") "Not Stand-alone" + path->test-case))) +(define (invalid-dir->test-suite d) + (dir->test-suite + d "Invalid" + (lambda (f) + (test-false (path->string f) + (validate-xml? (read-xml/file f)))))) +; XXX also check canonical xml +(define (valid-dir->test-suite d) + (define (path->test-case f) + (test-not-false (path->string f) + (validate-xml? (read-xml/file f)))) + (test-suite + "Valid" + (dir->test-suite + (build-path d "sa") "Stand-alone" + path->test-case) + (dir->test-suite + (build-path d "ext-sa") "External Stand-alone" + path->test-case) + (dir->test-suite + (build-path d "not-sa") "Not Stand-alone" + path->test-case))) + +(define (directory->test-suite d) + (test-suite + "James Clark's XML Test Cases" + + (not-wf-dir->test-suite (build-path d "not-wf")) + (invalid-dir->test-suite (build-path d "invalid")) + (valid-dir->test-suite (build-path d "valid")))) + +(define-runtime-path + clark-tests-dir + (list 'lib "xml/clark-tests" "tests")) + +(define clark-tests + (directory->test-suite + clark-tests-dir)) + +(run-tests clark-tests) \ No newline at end of file diff --git a/collects/tests/xml/test.ss b/collects/tests/xml/test.ss index 434c2106d1..6fd84aadf1 100644 --- a/collects/tests/xml/test.ss +++ b/collects/tests/xml/test.ss @@ -3,6 +3,7 @@ (planet schematics/schemeunit:3/text-ui) xml xml/plist + mzlib/etc "to-list.ss") ;; test-bad-read-input : format-str str -> void @@ -30,7 +31,7 @@ (define test-syntax:read-xml/element/exn (mk-test-read-xml/exn syntax:read-xml/element)) (define (test-syntax:read-xml/element str xml) - (test-equal? str (syntax->datum (read-xml/element (open-input-string str))) xml)) + (test-equal? str (syntax->datum (syntax:read-xml/element (open-input-string str))) xml)) (define (test-write-xml str) (test-equal? str (with-output-to-string (lambda () (write-xml (read-xml (open-input-string str))))) str)) @@ -51,6 +52,57 @@ (test-suite "XML" + (test-suite + "Legacy tests" + + (test-suite + "DOCTYPE" + + (let () + (define source-string #< + +END + ) + + (define source-document + (read-xml (open-input-string source-string))) + (define result-string + (with-output-to-string (lambda () (write-xml source-document)))) + (define expected-string #< +END + ) + (test-equal? + "DOCTYPE dropping" result-string expected-string))) + + (local + [(define a-pi (make-p-i #f #f "foo" "bar")) + (define a-p (make-prolog empty #f empty)) + (define a-p/pi (make-prolog (list a-pi) #f (list))) + (define a-d0 + (make-document a-p (make-element #f #f 'html empty empty) + empty)) + (define a-d1 + (make-document a-p (make-element #f #f 'html empty empty) + (list a-pi))) + (define a-d2 + (make-document a-p/pi (make-element #f #f 'html empty empty) + (list a-pi)))] + (test-suite + "PIs" + (test-equal? "Display XML w/o pis" + (with-output-to-string (lambda () (display-xml a-d0))) + "\n") + (test-equal? "Display XML w/ pi in doc-misc" + (with-output-to-string (lambda () (display-xml a-d1))) + "\n\n") + (test-equal? "Display XML w/ pi in doc-misc and prolog" + (with-output-to-string (lambda () (display-xml a-d2))) + "\n\n\n")))) + (test-suite "Datatypes" (test-suite @@ -69,12 +121,12 @@ (test-not-false "xexpr/c" (contract? xexpr/c)) - (test-not-false "document" (document? (make-document (make-prolog empty #f) (make-element #f #f 'br empty empty) empty))) + (test-not-false "document" (document? (make-document (make-prolog empty #f empty) (make-element #f #f 'br empty empty) empty))) - (test-not-false "prolog" (prolog? (make-prolog empty #f))) + (test-not-false "prolog" (prolog? (make-prolog empty #f empty))) (let ([c1 (make-comment "c1")] [c2 (make-comment "c2")]) - (test-equal? "prolog" (prolog-misc2 (make-prolog empty #f c1 c2)) + (test-equal? "prolog" (prolog-misc2 (make-prolog empty #f (list c1 c2))) (list c1 c2))) (test-not-false "document-type" (document-type? (make-document-type 'name (make-external-dtd "string") #f))) @@ -138,7 +190,7 @@ (test-read-xml "hi there!" '(make-document - (make-prolog (list) #f) + (make-prolog (list) #f (list)) (make-element (make-source (make-location 1 0 1) (make-location 1 33 34)) 'doc @@ -155,7 +207,7 @@ (test-read-xml "inner" '(make-document - (make-prolog (list) #f) + (make-prolog (list) #f (list)) (make-element (make-source (make-location 1 0 1) (make-location 1 21 22)) 'a @@ -166,7 +218,7 @@ (test-read-xml " " '(make-document - (make-prolog (list) #f) + (make-prolog (list) #f (list)) (make-element (make-source (make-location 1 0 1) (make-location 1 19 20)) 'root @@ -177,7 +229,7 @@ (test-read-xml "(" '(make-document - (make-prolog (list) #f) + (make-prolog (list) #f (list)) (make-element (make-source (make-location 1 0 1) (make-location 1 18 19)) 'root @@ -188,7 +240,7 @@ (test-read-xml "
" '(make-document - (make-prolog (list) #f) + (make-prolog (list) #f (list)) (make-element (make-source (make-location 1 16 17) (make-location 1 22 23)) 'br (list) (list)) (list))) @@ -303,9 +355,9 @@ "(" '(root () 40)) - (test-syntax:read-xml/exn + (test-syntax:read-xml "
" - "read-xml: parse-error: expected root element - received #f") + '(br ())) ; XXX need more syntax:read-xml tests @@ -352,7 +404,7 @@ (test-syntax:read-xml/element/exn "
" - "read-xml: parse-error: expected root element - received #f") + "read-xml: parse-error: expected root element - received #") ; XXX need more syntax:read-xml/element tests @@ -399,60 +451,210 @@ ) ) - (test-suite - "XML and X-expression Conversions" - - ; XXX permissive? - - ; XXX xml->xexpr - - ; XXX xexpr->string - - ; XXX eliminate-whitespace - - ; XXX validate-xexpr - - ; XXX correct-xexpr? - - ) + (local + [(define (test-xml->xexpr str xe) + (test-equal? str (xml->xexpr (document-element (read-xml (open-input-string str)))) xe)) + (define (test-xexpr->string xe str) + (test-equal? (format "~S" xe) (xexpr->string xe) str))] + (test-suite + "XML and X-expression Conversions" + + (test-suite + "xml->xexpr" + (test-xml->xexpr + "hi there!" + '(doc () (bold () "hi") " there!")) + + (test-xml->xexpr + "inner" + '(a ([href "#"]) "inner")) + + (test-xml->xexpr + " " + '(root () nbsp)) + + (test-xml->xexpr + "(" + '(root () 40)) + + ; XXX more xml->xexpr tests + ) + + (test-suite + "xexpr->string" + (test-xexpr->string '(doc () (bold () "hi") " there!") + "hi there!") + (test-xexpr->string '(a ([href "#"]) "inner") + "inner") + (test-xexpr->string '(root () nbsp) + " ") + (test-xexpr->string '(root () 40) + "(") + ; XXX more xexpr->string tests + ) + + (local + [(define (test-eliminate-whitespace tags choose str res) + (test-equal? (format "~S" (list tags choose str)) + (with-output-to-string + (lambda () + (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str)))))) + res)) + (define (test-eliminate-whitespace/exn tags choose str msg) + (test-exn (format "~S" (list tags choose str)) + (lambda (x) + (and (exn? x) + (regexp-match (regexp-quote msg) (exn-message x)))) + (lambda () + (with-output-to-string + (lambda () + (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str))))))))) + (define (truer x) #t)] + (test-suite + "eliminate-whitespace" + + (test-eliminate-whitespace empty identity "\n

Hey

" "\n

Hey

") + (test-eliminate-whitespace/exn empty not "\n

Hey

" "not allowed to contain text") + (test-eliminate-whitespace/exn empty truer "\n

Hey

" "not allowed to contain text") + + (test-eliminate-whitespace '(html) identity "\n

Hey

" "

Hey

") + (test-eliminate-whitespace/exn '(html) not "\n

Hey

" "not allowed to contain text") + (test-eliminate-whitespace/exn '(html) truer "\n

Hey

" "not allowed to contain text") + + (test-eliminate-whitespace '(html) identity "\n

\n

" "

\n

") + (test-eliminate-whitespace '(html) not "\n

\n

" "\n

") + (test-eliminate-whitespace '(html) truer "\n

\n

" "

"))) + + (local + [(define (test-validate-xexpr xe) + (test-not-false (format "~S" xe) (validate-xexpr xe))) + (define (test-validate-xexpr/exn xe v) + (test-exn (format "~S" xe) + (lambda (x) + (and (exn:invalid-xexpr? x) + (equal? (exn:invalid-xexpr-code x) v))) + (lambda () + (validate-xexpr xe))))] + (test-suite + "validate-xexpr" + (test-validate-xexpr 4) + (test-validate-xexpr 'nbsp) + (test-validate-xexpr "string") + (test-validate-xexpr (make-pcdata #f #f "pcdata")) + (test-validate-xexpr (make-cdata #f #f "cdata")) + (test-validate-xexpr (make-comment "comment")) + (test-validate-xexpr (make-p-i #f #f "s1" "s2")) + (test-validate-xexpr '(br)) + (test-validate-xexpr '(br ())) + (test-validate-xexpr '(a ([href "#"]) "string")) + + (test-validate-xexpr/exn #f #f) + (test-validate-xexpr/exn + +) + (test-validate-xexpr/exn '(a ([href foo]) bar) 'foo) + (test-validate-xexpr/exn '("foo" bar) '("foo" bar)))) + + ; XXX correct-xexpr? + + (test-suite + "permissive?" + (test-exn + "Non-permissive" + (lambda (exn) + (and (exn? exn) + (regexp-match #rx"Expected content," (exn-message exn)))) + (lambda () + (xml->xexpr #f))) + + (test-false + "Permissive" + (parameterize ([permissive? #t]) + (xml->xexpr #f)))))) - (test-suite - "Parameters" - - ; XXX empty-tag-shorthand - - ; XXX html-empty-tags - - ; XXX collapse-whitespace - - ; XXX read-comments - - ; XXX xexpr-drop-empty-attributes - - ) + (local + [(define ((mk-test-param param) v istr ostr) + (test-equal? (format "~S" (list v istr)) + (parameterize ([param v]) + (with-output-to-string + (lambda () + (write-xml (read-xml (open-input-string istr)))))) + ostr)) + (define test-empty-tag-shorthand (mk-test-param empty-tag-shorthand)) + (define test-collapse-whitespace (mk-test-param collapse-whitespace)) + (define test-read-comments (mk-test-param read-comments))] + (test-suite + "Parameters" + + (test-suite + "empty-tag-shorthand" + (test-empty-tag-shorthand 'always "" "") + (test-empty-tag-shorthand 'always "Hey" "Hey") + (test-empty-tag-shorthand 'never "" "") + (test-empty-tag-shorthand 'never "Hey" "Hey") + (test-empty-tag-shorthand empty "" "") + (test-empty-tag-shorthand empty "Hey" "Hey") + (test-empty-tag-shorthand '(html) "" "") + (test-empty-tag-shorthand '(html) "Hey" "Hey") + (test-empty-tag-shorthand '(p) "" "") + (test-empty-tag-shorthand '(p) "Hey" "Hey")) + + (test-equal? "html-empty-tags" + html-empty-tags + '(param meta link isindex input img hr frame col br basefont base area)) + + (test-suite + "collapse-whitespace" + (test-collapse-whitespace #t "\n" " ") + (test-collapse-whitespace #t "\t" " ") + (test-collapse-whitespace #t " " " ") + (test-collapse-whitespace #t "" "") + (test-collapse-whitespace #t "" "") + (test-collapse-whitespace #t "" "") + (test-collapse-whitespace #f "\n" "\n")) + + (test-suite + "read-comments" + (test-read-comments #f "" "") + (test-read-comments #t "" "")) + + (local + [(define (test-xexpr-drop-empty-attributes v istr xe) + (test-equal? (format "~S" (list v istr)) + (parameterize ([xexpr-drop-empty-attributes v]) + (xml->xexpr (document-element (read-xml (open-input-string istr))))) + xe))] + (test-suite + "xexpr-drop-empty-attributes" + + (test-xexpr-drop-empty-attributes #f "" '(html ())) + (test-xexpr-drop-empty-attributes #t "" '(html)) + (test-xexpr-drop-empty-attributes #f "Hey" '(html () "Hey")) + (test-xexpr-drop-empty-attributes #t "Hey" '(html "Hey")) + (test-xexpr-drop-empty-attributes #f "Hey" '(a ([href "#"]) "Hey")) + (test-xexpr-drop-empty-attributes #t "Hey" '(a ([href "#"]) "Hey")))))) - (local [(define example - `(dict (assoc-pair "first-key" - "just a string with some whitespace in it") - (assoc-pair "second-key" - (false)) - (assoc-pair "third-key" - (dict )) - (assoc-pair "fourth-key" - (dict (assoc-pair "inner-key" - (real 3.432)))) - (assoc-pair "fifth-key" - (array (integer 14) - "another string" - (true))) - (assoc-pair "sixth-key" - (array)))) - (define example-str #< first-keyjust a string with some whitespace in itsecond-keythird-keyfourth-keyinner-key3.432fifth-key14another stringsixth-key END - )] + )] (test-suite "PList Library" @@ -496,74 +698,6 @@ END (write-plist plist out) (close-output-port out) (test-equal? (format "~S" plist) (read-plist in) plist))] - (test-plist-round-trip example)) - - )) - - (test-suite - "Legacy tests" - - (test-suite - "xml->xexpr" - (test-exn - "Non-permissive" - (lambda (exn) - (and (exn? exn) - (regexp-match #rx"Expected content," (exn-message exn)))) - (lambda () - (xml->xexpr #f))) - - (test-false - "Permissive" - (parameterize ([permissive? #t]) - (xml->xexpr #f)))) - - (test-suite - "DOCTYPE" - - (let () - (define source-string #< - -END - ) - - (define source-document - (read-xml (open-input-string source-string))) - (define result-string - (with-output-to-string (lambda () (write-xml source-document)))) - (define expected-string #< -END - ) - (test-equal? - "DOCTYPE dropping" result-string expected-string))) - - (let () - (define a-pi (make-p-i #f #f "foo" "bar")) - (define a-p (make-prolog empty #f)) - (define a-p/pi (make-prolog (list a-pi) #f)) - (define a-d0 - (make-document a-p (make-element #f #f 'html empty empty) - empty)) - (define a-d1 - (make-document a-p (make-element #f #f 'html empty empty) - (list a-pi))) - (define a-d2 - (make-document a-p/pi (make-element #f #f 'html empty empty) - (list a-pi))) - (test-suite - "PIs" - (test-equal? "Display XML w/o pis" - (with-output-to-string (lambda () (display-xml a-d0))) - "\n") - (test-equal? "Display XML w/ pi in doc-misc" - (with-output-to-string (lambda () (display-xml a-d1))) - "\n\n") - (test-equal? "Display XML w/ pi in doc-misc and prolog" - (with-output-to-string (lambda () (display-xml a-d2))) - "\n\n\n")))))) + (test-plist-round-trip example)))))) (run-tests xml-tests) \ No newline at end of file diff --git a/collects/tests/xml/to-list.ss b/collects/tests/xml/to-list.ss index f34a3eaba2..1c954c9489 100644 --- a/collects/tests/xml/to-list.ss +++ b/collects/tests/xml/to-list.ss @@ -8,10 +8,10 @@ (element->list (document-element xml)) (list* 'list (map misc->list (document-misc xml))))) (define (prolog->list p) - (list* 'make-prolog + (list 'make-prolog (list* 'list (map misc->list (prolog-misc p))) (dtd->list (prolog-dtd p)) - (map misc->list (prolog-misc2 p)))) + (list* 'list (map misc->list (prolog-misc2 p))))) (define (dtd->list d) (if d (list 'make-document-type diff --git a/collects/xml/plist.ss b/collects/xml/plist.ss index 6e06e75a3f..80cf581b29 100644 --- a/collects/xml/plist.ss +++ b/collects/xml/plist.ss @@ -1,184 +1,185 @@ -(module plist mzscheme +#lang scheme +(require xml) - (require "xml.ss" - mzlib/contract) +; a dict is (list 'dict assoc-pair ...) +; an assoc-pair is (list 'assoc-pair key value) +; a key is a string +; a value is either: +; a string, +; a boolean, +; an integer : (list 'integer number) +; a real : (list 'real number) +; a dict, or +; an array : (list 'array value ...) +; (we're ignoring data & date) - ; a dict is (list 'dict assoc-pair ...) - ; an assoc-pair is (list 'assoc-pair key value) - ; a key is a string - ; a value is either: - ; a string, - ; a boolean, - ; an integer : (list 'integer number) - ; a real : (list 'real number) - ; a dict, or - ; an array : (list 'array value ...) - ; (we're ignoring data & date) - - (define (plist-dict? v) - (and (list? v) - (pair? v) - (eq? (car v) 'dict) - (andmap (lambda (v) - (and (list? v) - (= 3 (length v)) - (eq? (car v) 'assoc-pair) - (string? (cadr v)) - (let pl-value? ([v (caddr v)]) - (or (string? v) - (and (pair? v) - (case (car v) - [(true) (null? (cdr v))] - [(false) (null? (cdr v))] - [(integer) (and (= (length v) 2) - (exact-integer? (cadr v)))] - [(real) (and (= (length v) 2) - (real? (cadr v)))] - [(array) (andmap pl-value? (cdr v))] - [else (plist-dict? v)])))))) - (cdr v)))) +(define (plist-dict? v) + (and (list? v) + (pair? v) + (eq? (car v) 'dict) + (andmap (lambda (v) + (and (list? v) + (= 3 (length v)) + (eq? (car v) 'assoc-pair) + (string? (cadr v)) + (let pl-value? ([v (caddr v)]) + (or (string? v) + (and (pair? v) + (case (car v) + [(true) (null? (cdr v))] + [(false) (null? (cdr v))] + [(integer) (and (= (length v) 2) + (exact-integer? (cadr v)))] + [(real) (and (= (length v) 2) + (real? (cadr v)))] + [(array) (andmap pl-value? (cdr v))] + [else (plist-dict? v)])))))) + (cdr v)))) - ; raise-plist-exn : string mark-set xexpr symbol -> ??? - (define (raise-plist-exn tag mark-set xexpr type) - (raise (make-exn:fail:contract (string-append "badly formed '" tag "'") - mark-set))) +; raise-plist-exn : string mark-set xexpr symbol -> ??? +(define (raise-plist-exn tag mark-set xexpr type) + (raise (make-exn:fail:contract (string-append "badly formed '" tag "'") + mark-set))) - ; expand-dict : xexpr -> xexpr - (define (expand-dict x) - (cond [(and (eq? (car x) 'dict) - (map expand-assoc-pair (cdr x))) - => - (lambda (x) `(dict ,@(apply append x)))] - [else - (raise-plist-exn "dict" (current-continuation-marks) x 'plist:dict)])) +; expand-dict : xexpr -> xexpr +(define (expand-dict x) + (cond [(and (eq? (car x) 'dict) + (map expand-assoc-pair (cdr x))) + => + (lambda (x) `(dict ,@(apply append x)))] + [else + (raise-plist-exn "dict" (current-continuation-marks) x 'plist:dict)])) - ; expand-assoc-pair : xexpr -> (list xexpr xexpr) - (define (expand-assoc-pair x) - (cond [(and (eq? (car x) 'assoc-pair) - (string? (cadr x)) - (expand-value (caddr x))) - => - (lambda (z) `((key ,(cadr x)) - ,z))] - [else - (raise-plist-exn "assoc-pair" (current-continuation-marks) x 'plist:assoc-pair)])) +; expand-assoc-pair : xexpr -> (list xexpr xexpr) +(define (expand-assoc-pair x) + (cond [(and (eq? (car x) 'assoc-pair) + (string? (cadr x)) + (expand-value (caddr x))) + => + (lambda (z) `((key ,(cadr x)) + ,z))] + [else + (raise-plist-exn "assoc-pair" (current-continuation-marks) x 'plist:assoc-pair)])) - ; expand-value : xexpr -> xexpr - (define (expand-value x) - (cond [(string? x) - `(string ,x)] - [(or (equal? x '(true)) - (equal? x '(false))) - x] - [(and (eq? (car x) 'integer) - (expand-integer x)) - => - (lambda (x) x)] - [(and (eq? (car x) 'real) - (expand-real x)) - => - (lambda (x) x)] - [(and (eq? (car x) 'dict) - (expand-dict x)) - => - (lambda (x) x)] - [(and (eq? (car x) 'array) - (expand-array x)) - => - (lambda (x) x)] - [else - (raise-plist-exn "value" (current-continuation-marks) x 'plist:value)])) +; expand-value : xexpr -> xexpr +(define (expand-value x) + (cond [(string? x) + `(string ,x)] + [(or (equal? x '(true)) + (equal? x '(false))) + x] + [(and (eq? (car x) 'integer) + (expand-integer x)) + => + (lambda (x) x)] + [(and (eq? (car x) 'real) + (expand-real x)) + => + (lambda (x) x)] + [(and (eq? (car x) 'dict) + (expand-dict x)) + => + (lambda (x) x)] + [(and (eq? (car x) 'array) + (expand-array x)) + => + (lambda (x) x)] + [else + (raise-plist-exn "value" (current-continuation-marks) x 'plist:value)])) - ; expand-real : xexpr -> xexpr - (define (expand-real x) - (cond [(and (eq? (car x) 'real) - (real? (cadr x))) - `(real ,(number->string (cadr x)))] - [else - (raise-plist-exn "real" (current-continuation-marks) x 'plist:real)])) +; expand-real : xexpr -> xexpr +(define (expand-real x) + (cond [(and (eq? (car x) 'real) + (real? (cadr x))) + `(real ,(number->string (cadr x)))] + [else + (raise-plist-exn "real" (current-continuation-marks) x 'plist:real)])) - ; expand-integer : xexpr -> xexpr - (define (expand-integer x) - (cond [(and (eq? (car x) 'integer) - (integer? (cadr x))) - `(integer ,(number->string (cadr x)))] - [else - (raise-plist-exn "integer" (current-continuation-marks) x 'plist:integer)])) +; expand-integer : xexpr -> xexpr +(define (expand-integer x) + (cond [(and (eq? (car x) 'integer) + (integer? (cadr x))) + `(integer ,(number->string (cadr x)))] + [else + (raise-plist-exn "integer" (current-continuation-marks) x 'plist:integer)])) - ; expand-array : xexpr -> xexpr - (define (expand-array x) - (cond [(and (eq? (car x) 'array) - (map expand-value (cdr x))) - => - (lambda (x) - `(array ,@x))] - [else - (raise-plist-exn "array" (current-continuation-marks) x 'plist:array)])) +; expand-array : xexpr -> xexpr +(define (expand-array x) + (cond [(and (eq? (car x) 'array) + (map expand-value (cdr x))) + => + (lambda (x) + `(array ,@x))] + [else + (raise-plist-exn "array" (current-continuation-marks) x 'plist:array)])) - ; dict? tst -> boolean - (define (dict? x) - (with-handlers [(exn:fail:contract? (lambda (exn) #f))] - (expand-dict x) - #t)) +; dict? tst -> boolean +(define (dict? x) + (with-handlers [(exn:fail:contract? (lambda (exn) #f))] + (expand-dict x) + #t)) - ; write-plist : xexpr port -> (void) - (define (write-plist xexpr port) - (let ([plist-xexpr `(plist ,(expand-dict xexpr))]) - (write-xml - (make-document (make-prolog (list (make-pi #f #f 'xml "version=\"1.0\" encoding=\"UTF-8\"")) - (make-document-type 'plist - (if (eq? (system-type) 'macosx) - (make-external-dtd/system - "file://localhost/System/Library/DTDs/PropertyList.dtd") - #f) - #f)) - (xexpr->xml `(plist ((version "0.9")) - ,(expand-dict xexpr))) - null) - port))) +; write-plist : xexpr port -> (void) +(define (write-plist xexpr port) + (let ([plist-xexpr `(plist ,(expand-dict xexpr))]) + (write-xml + (make-document (make-prolog (list (make-p-i #f #f 'xml "version=\"1.0\" encoding=\"UTF-8\"")) + (make-document-type 'plist + (if (eq? (system-type) 'macosx) + (make-external-dtd/system + "file://localhost/System/Library/DTDs/PropertyList.dtd") + #f) + #f) + empty) + (xexpr->xml `(plist ((version "0.9")) + ,(expand-dict xexpr))) + null) + port))) - ; collapse-dict : xexpr -> dict - (define (collapse-dict x) - `(dict ,@(collapse-assoc-pairs (cdr x)))) +; collapse-dict : xexpr -> dict +(define (collapse-dict x) + `(dict ,@(collapse-assoc-pairs (cdr x)))) - ; collapse-assoc-pairs : (listof xexpr) -> (listof assoc-pairs) - (define (collapse-assoc-pairs args) - (if (null? args) - null - (let ([key (car args)] - [value (cadr args)] - [rest (cddr args)]) - (cons `(assoc-pair ,(cadr key) ,(collapse-value value)) - (collapse-assoc-pairs rest))))) +; collapse-assoc-pairs : (listof xexpr) -> (listof assoc-pairs) +(define (collapse-assoc-pairs args) + (if (null? args) + null + (let ([key (car args)] + [value (cadr args)] + [rest (cddr args)]) + (cons `(assoc-pair ,(cadr key) ,(collapse-value value)) + (collapse-assoc-pairs rest))))) - ; collapse-value : xexpr -> value - (define (collapse-value value) - (case (car value) - [(string) (cadr value)] - [(true false) value] - [(integer real) (list (car value) (string->number (cadr value)))] - [(dict) (collapse-dict value)] - [(array) (collapse-array value)])) +; collapse-value : xexpr -> value +(define (collapse-value value) + (case (car value) + [(string) (cadr value)] + [(true false) value] + [(integer real) (list (car value) (string->number (cadr value)))] + [(dict) (collapse-dict value)] + [(array) (collapse-array value)])) - ; collapse-array : xexpr -> array - (define (collapse-array xexpr) - `(array ,@(map collapse-value (cdr xexpr)))) +; collapse-array : xexpr -> array +(define (collapse-array xexpr) + `(array ,@(map collapse-value (cdr xexpr)))) - (define tags-without-whitespace - '(plist dict array)) +(define tags-without-whitespace + '(plist dict array)) - ; read-plist : port -> dict - (define (read-plist port) - (let* ([xml-doc (read-xml port)] - [content (parameterize ([xexpr-drop-empty-attributes #t]) - (xml->xexpr - ((eliminate-whitespace tags-without-whitespace (lambda (x) x)) - (document-element xml-doc))))]) - (unless (eq? (car content) 'plist) - (error 'read-plist "xml expression is not a plist: ~a" content)) - (collapse-dict (caddr content)))) +; read-plist : port -> dict +(define (read-plist port) + (let* ([xml-doc (read-xml port)] + [content (parameterize ([xexpr-drop-empty-attributes #t]) + (xml->xexpr + ((eliminate-whitespace tags-without-whitespace (lambda (x) x)) + (document-element xml-doc))))]) + (unless (eq? (car content) 'plist) + (error 'read-plist "xml expression is not a plist: ~a" content)) + (collapse-dict (caddr content)))) - (provide plist-dict? read-plist) - (provide/contract [write-plist (plist-dict? output-port? . -> . void?)])) +(provide/contract + [plist-dict? (any/c . -> . boolean?)] + [read-plist (input-port? . -> . plist-dict?)] + [write-plist (plist-dict? output-port? . -> . void?)]) \ No newline at end of file diff --git a/collects/xml/private/reader.ss b/collects/xml/private/reader.ss index 0c0d940242..5eb020581b 100644 --- a/collects/xml/private/reader.ss +++ b/collects/xml/private/reader.ss @@ -1,466 +1,462 @@ -(module reader mzscheme - (require mzlib/unitsig - mzlib/list - mzlib/etc) +#lang scheme +(require "sig.ss") + +(provide reader@) + +(define-unit reader@ + (import xml-structs^) + (export reader^) - (require "sig.ss") + ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) + (define-struct (start-tag source) (name attrs)) - (provide reader@) + ;; End-tag ::= (make-end-tag Location Location Symbol) + (define-struct (end-tag source) (name)) - (define reader@ - (unit/sig reader^ - (import xml-structs^) - - ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) - (define-struct (start-tag source) (name attrs)) - - ;; End-tag ::= (make-end-tag Location Location Symbol) - (define-struct (end-tag source) (name)) - - ;; Token ::= Contents | Start-tag | End-tag | Eof - - (define read-comments (make-parameter #f)) - (define collapse-whitespace (make-parameter #f)) - - ;; read-xml : [Input-port] -> Document - (define read-xml - (opt-lambda ([in (current-input-port)]) - (let*-values ([(in pos) (positionify in)] - [(misc0 start) (read-misc in pos)]) - (make-document (make-prolog misc0 #f) - (read-xml-element-helper pos in start) - (let ([loc-before (pos)]) - (let-values ([(misc1 end-of-file) (read-misc in pos)]) - (unless (eof-object? end-of-file) - (let ([loc-after (pos)]) - (parse-error (list - (make-srcloc - (object-name in) - #f - #f - (location-offset loc-before) - (- (location-offset loc-after) - (location-offset loc-before)))) - "extra stuff at end of document ~e" - end-of-file))) - misc1)))))) - - ;; read-xml/element : [Input-port] -> Element - (define read-xml/element - (opt-lambda ([in (current-input-port)]) - (let-values ([(in pos) (positionify in)]) - (skip-space in) - (read-xml-element-helper pos in (lex in pos))))) - - ;; read-xml-element-helper : Nat Iport Token -> Element - (define (read-xml-element-helper pos in start) + ;; Token ::= Contents | Start-tag | End-tag | Eof + + (define read-comments (make-parameter #f)) + (define collapse-whitespace (make-parameter #f)) + + ;; read-xml : [Input-port] -> Document + (define read-xml + (lambda ([in (current-input-port)]) + (let*-values ([(in pos) (positionify in)] + [(misc0 start) (read-misc in pos)]) + (make-document (make-prolog misc0 #f empty) + (read-xml-element-helper pos in start) + (let ([loc-before (pos)]) + (let-values ([(misc1 end-of-file) (read-misc in pos)]) + (unless (eof-object? end-of-file) + (let ([loc-after (pos)]) + (parse-error (list + (make-srcloc + (object-name in) + #f + #f + (location-offset loc-before) + (- (location-offset loc-after) + (location-offset loc-before)))) + "extra stuff at end of document ~e" + end-of-file))) + misc1)))))) + + ;; read-xml/element : [Input-port] -> Element + (define read-xml/element + (lambda ([in (current-input-port)]) + (let-values ([(in pos) (positionify in)]) + (skip-space in) + (read-xml-element-helper pos in (lex in pos))))) + + ;; read-xml-element-helper : Nat Iport Token -> Element + (define (read-xml-element-helper pos in start) + (cond + [(start-tag? start) (read-element start in pos)] + [(element? start) start] + [else (parse-error (list + (make-srcloc + (object-name in) + #f + #f + 1 + (- (location-offset (pos)) 1))) + "expected root element - received ~e" + (if (pcdata? start) (pcdata-string start) start))])) + + ;; read-misc : Input-port (-> Location) -> (listof Misc) Token + (define (read-misc in pos) + (let read-more () + (let ([x (lex in pos)]) (cond - [(start-tag? start) (read-element start in pos)] - [(element? start) start] - [else (parse-error (list - (make-srcloc - (object-name in) - #f - #f - 1 - (- (location-offset (pos)) 1))) - "expected root element - received ~e" - (if (pcdata? start) (pcdata-string start) start))])) - - ;; read-misc : Input-port (-> Location) -> (listof Misc) Token - (define (read-misc in pos) - (let read-more () - (let ([x (lex in pos)]) - (cond - [(pi? x) - (let-values ([(lst next) (read-more)]) - (values (cons x lst) next))] - [(comment? x) - (let-values ([(lst next) (read-more)]) - (if (read-comments) - (values (cons x lst) next) - (values lst next)))] - [(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x)))) - (read-more)] - [else (values null x)])))) - - ;; read-element : Start-tag Input-port (-> Location) -> Element - (define (read-element start in pos) - (let ([name (start-tag-name start)] - [a (source-start start)] - [b (source-stop start)]) - (let read-content ([k (lambda (body end-loc) - (make-element - a end-loc name (start-tag-attrs start) - body))]) - (let ([x (lex in pos)]) + [(pi? x) + (let-values ([(lst next) (read-more)]) + (values (cons x lst) next))] + [(comment? x) + (let-values ([(lst next) (read-more)]) + (if (read-comments) + (values (cons x lst) next) + (values lst next)))] + [(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x)))) + (read-more)] + [else (values null x)])))) + + ;; read-element : Start-tag Input-port (-> Location) -> Element + (define (read-element start in pos) + (let ([name (start-tag-name start)] + [a (source-start start)] + [b (source-stop start)]) + (let read-content ([k (lambda (body end-loc) + (make-element + a end-loc name (start-tag-attrs start) + body))]) + (let ([x (lex in pos)]) + (cond + [(eof-object? x) + (parse-error (list + (make-srcloc + (object-name in) + #f + #f + (location-offset (source-start start)) + (- (location-offset (source-stop start)) + (location-offset (source-start start))))) + "unclosed `~a' tag at [~a ~a]" + name + (format-source a) + (format-source b))] + [(start-tag? x) + (let ([next-el (read-element x in pos)]) + (read-content (lambda (body end-loc) + (k (cons next-el body) + end-loc))))] + [(end-tag? x) + (let ([end-loc (source-stop x)]) + (unless (eq? name (end-tag-name x)) + (parse-error + (list + (make-srcloc (object-name in) + #f + #f + (location-offset a) + (- (location-offset b) (location-offset a))) + (make-srcloc (object-name in) + #f + #f + (location-offset (source-start x)) + (- (location-offset end-loc) (location-offset (source-start x))))) + "start tag `~a' at [~a ~a] doesn't match end tag `~a' at [~a ~a]" + name + (format-source a) + (format-source b) + (end-tag-name x) + (format-source (source-start x)) + (format-source end-loc))) + (k null end-loc))] + [(entity? x) (read-content (lambda (body end-loc) + (k (cons (expand-entity x) body) + end-loc)))] + [(comment? x) (if (read-comments) + (read-content (lambda (body end-loc) (k (cons x body) end-loc))) + (read-content k))] + [else (read-content (lambda (body end-loc) (k (cons x body) end-loc)))]))))) + + ;; expand-entity : Entity -> (U Entity Pcdata) + ;; more here - allow expansion of user defined entities + (define (expand-entity x) + (let ([expanded (default-entity-table (entity-text x))]) + (if expanded + (make-pcdata (source-start x) (source-stop x) expanded) + x))) + + ;; default-entity-table : Symbol -> (U #f String) + (define (default-entity-table name) + (case name + [(amp) "&"] + [(lt) "<"] + [(gt) ">"] + [(quot) "\""] + [(apos) "'"] + [else #f])) + + ;; lex : Input-port (-> Location) -> (U Token special) + (define (lex in pos) + (let ([c (peek-char-or-special in)]) + (cond + [(eof-object? c) c] + [(eq? c #\&) (lex-entity in pos)] + [(eq? c #\<) (lex-tag-cdata-pi-comment in pos)] + [(not (char? c)) (read-char-or-special in)] + [else (lex-pcdata in pos)]))) + + ; lex-entity : Input-port (-> Location) -> Entity + ; pre: the first char is a #\& + (define (lex-entity in pos) + (let ([start (pos)]) + (read-char in) + (let ([data (case (peek-char in) + [(#\#) + (read-char in) + (let ([n (case (peek-char in) + [(#\x) (read-char in) + (string->number (read-until #\; in pos) 16)] + [else (string->number (read-until #\; in pos))])]) + (unless (number? n) + (lex-error in pos "malformed numeric entity")) + n)] + [else + (begin0 + (lex-name in pos) + (unless (eq? (read-char in) #\;) + (lex-error in pos "expected ; at the end of an entity")))])]) + (make-entity start (pos) data)))) + + ; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Cdata | Pi | Comment + ; pre: the first char is a #\< + (define (lex-tag-cdata-pi-comment in pos) + (let ([start (pos)]) + (read-char in) + (case (non-eof peek-char-or-special in pos) + [(#\!) + (read-char in) + (case (non-eof peek-char in pos) + [(#\-) (read-char in) + (unless (eq? (read-char-or-special in) #\-) + (lex-error in pos "expected second - after ) + (lex-error in pos "expected > to end comment (\"--\" can't appear in comments)")) + ;(make-comment start (pos) data) + (make-comment data))] + [(#\[) (read-char in) + (unless (string=? (read-string 6 in) "CDATA[") + (lex-error in pos "expected CDATA following <[")) + (let ([data (lex-cdata-contents in pos)]) + (make-cdata start (pos) (format "" data)))] + [else (skip-dtd in pos) + (skip-space in) + (unless (eq? (peek-char-or-special in) #\<) + (lex-error in pos "expected pi, comment, or element after doctype")) + (lex-tag-cdata-pi-comment in pos)])] + [(#\?) (read-char in) + (let ([name (lex-name in pos)]) + (skip-space in) + (let ([data (lex-pi-data in pos)]) + (make-pi start (pos) name data)))] + [(#\/) (read-char in) + (let ([name (lex-name in pos)]) + (skip-space in) + (unless (eq? (read-char-or-special in) #\>) + (lex-error in pos "expected > to close ~a's end tag" name)) + (make-end-tag start (pos) name))] + [else ; includes 'special, but lex-name will fail in that case + (let ([name (lex-name in pos)] + [attrs (lex-attributes in pos)]) + (skip-space in) + (case (read-char-or-special in) + [(#\/) + (unless (eq? (read-char in) #\>) + (lex-error in pos "expected > to close empty element ~a" name)) + (make-element start (pos) name attrs null)] + [(#\>) (make-start-tag start (pos) name attrs)] + [else (lex-error in pos "expected / or > to close tag `~a'" name)]))]))) + + ;; lex-attributes : Input-port (-> Location) -> (listof Attribute) + (define (lex-attributes in pos) + (sort (let loop () + (skip-space in) + (cond [(name-start? (peek-char-or-special in)) + (cons (lex-attribute in pos) (loop))] + [else null])) + (lambda (a b) + (let ([na (attribute-name a)] + [nb (attribute-name b)]) (cond - [(eof-object? x) - (parse-error (list - (make-srcloc - (object-name in) - #f - #f - (location-offset (source-start start)) - (- (location-offset (source-stop start)) - (location-offset (source-start start))))) - "unclosed `~a' tag at [~a ~a]" - name - (format-source a) - (format-source b))] - [(start-tag? x) - (let ([next-el (read-element x in pos)]) - (read-content (lambda (body end-loc) - (k (cons next-el body) - end-loc))))] - [(end-tag? x) - (let ([end-loc (source-stop x)]) - (unless (eq? name (end-tag-name x)) - (parse-error - (list - (make-srcloc (object-name in) - #f - #f - (location-offset a) - (- (location-offset b) (location-offset a))) - (make-srcloc (object-name in) - #f - #f - (location-offset (source-start x)) - (- (location-offset end-loc) (location-offset (source-start x))))) - "start tag `~a' at [~a ~a] doesn't match end tag `~a' at [~a ~a]" - name - (format-source a) - (format-source b) - (end-tag-name x) - (format-source (source-start x)) - (format-source end-loc))) - (k null end-loc))] - [(entity? x) (read-content (lambda (body end-loc) - (k (cons (expand-entity x) body) - end-loc)))] - [(comment? x) (if (read-comments) - (read-content (lambda (body end-loc) (k (cons x body) end-loc))) - (read-content k))] - [else (read-content (lambda (body end-loc) (k (cons x body) end-loc)))]))))) - - ;; expand-entity : Entity -> (U Entity Pcdata) - ;; more here - allow expansion of user defined entities - (define (expand-entity x) - (let ([expanded (default-entity-table (entity-text x))]) - (if expanded - (make-pcdata (source-start x) (source-stop x) expanded) - x))) - - ;; default-entity-table : Symbol -> (U #f String) - (define (default-entity-table name) - (case name - [(amp) "&"] - [(lt) "<"] - [(gt) ">"] - [(quot) "\""] - [(apos) "'"] - [else #f])) - - ;; lex : Input-port (-> Location) -> (U Token special) - (define (lex in pos) - (let ([c (peek-char-or-special in)]) - (cond - [(eof-object? c) c] - [(eq? c #\&) (lex-entity in pos)] - [(eq? c #\<) (lex-tag-cdata-pi-comment in pos)] - [(not (char? c)) (read-char-or-special in)] - [else (lex-pcdata in pos)]))) - - ; lex-entity : Input-port (-> Location) -> Entity - ; pre: the first char is a #\& - (define (lex-entity in pos) - (let ([start (pos)]) + [(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)] + [else (stringstring na) (symbol->string nb))]))))) + + ;; lex-attribute : Input-port (-> Location) -> Attribute + (define (lex-attribute in pos) + (let ([start (pos)] + [name (lex-name in pos)]) + (skip-space in) + (unless (eq? (read-char in) #\=) + (lex-error in pos "expected = in attribute ~a" name)) + (skip-space in) + ;; more here - handle entites and disallow "<" + (let* ([delimiter (read-char-or-special in)] + [value (case delimiter + [(#\' #\") + (list->string + (let read-more () + (let ([c (non-eof peek-char-or-special in pos)]) + (cond + [(eq? c 'special) + (lex-error in pos "attribute values cannot contain non-text values")] + [(eq? c delimiter) (read-char in) null] + [(eq? c #\&) + (let ([entity (expand-entity (lex-entity in pos))]) + (if (pcdata? entity) + (append (string->list (pcdata-string entity)) (read-more)) + ;; more here - do something with user defined entites + (read-more)))] + [else (read-char in) (cons c (read-more))]))))] + [else (if (char? delimiter) + (lex-error in pos "attribute values must be in ''s or in \"\"s") + delimiter)])]) + (make-attribute start (pos) name value)))) + + ;; skip-space : Input-port -> Void + ;; deviation - should sometimes insist on at least one space + (define (skip-space in) + (let loop () + (let ([c (peek-char-or-special in)]) + (when (and (char? c) + (char-whitespace? c)) (read-char in) - (let ([data (case (peek-char in) - [(#\#) - (read-char in) - (let ([n (case (peek-char in) - [(#\x) (read-char in) - (string->number (read-until #\; in pos) 16)] - [else (string->number (read-until #\; in pos))])]) - (unless (number? n) - (lex-error in pos "malformed numeric entity")) - n)] - [else - (begin0 - (lex-name in pos) - (unless (eq? (read-char in) #\;) - (lex-error in pos "expected ; at the end of an entity")))])]) - (make-entity start (pos) data)))) - - ; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Cdata | Pi | Comment - ; pre: the first char is a #\< - (define (lex-tag-cdata-pi-comment in pos) - (let ([start (pos)]) - (read-char in) - (case (non-eof peek-char-or-special in pos) - [(#\!) - (read-char in) - (case (non-eof peek-char in pos) - [(#\-) (read-char in) - (unless (eq? (read-char-or-special in) #\-) - (lex-error in pos "expected second - after ) - (lex-error in pos "expected > to end comment (\"--\" can't appear in comments)")) - ;(make-comment start (pos) data) - (make-comment data))] - [(#\[) (read-char in) - (unless (string=? (read-string 6 in) "CDATA[") - (lex-error in pos "expected CDATA following <[")) - (let ([data (lex-cdata-contents in pos)]) - (make-cdata start (pos) (format "" data)))] - [else (skip-dtd in pos) - (skip-space in) - (unless (eq? (peek-char-or-special in) #\<) - (lex-error in pos "expected pi, comment, or element after doctype")) - (lex-tag-cdata-pi-comment in pos)])] - [(#\?) (read-char in) - (let ([name (lex-name in pos)]) - (skip-space in) - (let ([data (lex-pi-data in pos)]) - (make-pi start (pos) name data)))] - [(#\/) (read-char in) - (let ([name (lex-name in pos)]) - (skip-space in) - (unless (eq? (read-char-or-special in) #\>) - (lex-error in pos "expected > to close ~a's end tag" name)) - (make-end-tag start (pos) name))] - [else ; includes 'special, but lex-name will fail in that case - (let ([name (lex-name in pos)] - [attrs (lex-attributes in pos)]) - (skip-space in) - (case (read-char-or-special in) - [(#\/) - (unless (eq? (read-char in) #\>) - (lex-error in pos "expected > to close empty element ~a" name)) - (make-element start (pos) name attrs null)] - [(#\>) (make-start-tag start (pos) name attrs)] - [else (lex-error in pos "expected / or > to close tag `~a'" name)]))]))) - - ;; lex-attributes : Input-port (-> Location) -> (listof Attribute) - (define (lex-attributes in pos) - (sort (let loop () - (skip-space in) - (cond [(name-start? (peek-char-or-special in)) - (cons (lex-attribute in pos) (loop))] - [else null])) - (lambda (a b) - (let ([na (attribute-name a)] - [nb (attribute-name b)]) - (cond - [(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)] - [else (stringstring na) (symbol->string nb))]))))) - - ;; lex-attribute : Input-port (-> Location) -> Attribute - (define (lex-attribute in pos) - (let ([start (pos)] - [name (lex-name in pos)]) - (skip-space in) - (unless (eq? (read-char in) #\=) - (lex-error in pos "expected = in attribute ~a" name)) - (skip-space in) - ;; more here - handle entites and disallow "<" - (let* ([delimiter (read-char-or-special in)] - [value (case delimiter - [(#\' #\") - (list->string - (let read-more () - (let ([c (non-eof peek-char-or-special in pos)]) - (cond - [(eq? c 'special) - (lex-error in pos "attribute values cannot contain non-text values")] - [(eq? c delimiter) (read-char in) null] - [(eq? c #\&) - (let ([entity (expand-entity (lex-entity in pos))]) - (if (pcdata? entity) - (append (string->list (pcdata-string entity)) (read-more)) - ;; more here - do something with user defined entites - (read-more)))] - [else (read-char in) (cons c (read-more))]))))] - [else (if (char? delimiter) - (lex-error in pos "attribute values must be in ''s or in \"\"s") - delimiter)])]) - (make-attribute start (pos) name value)))) - - ;; skip-space : Input-port -> Void - ;; deviation - should sometimes insist on at least one space - (define (skip-space in) - (let loop () - (let ([c (peek-char-or-special in)]) - (when (and (char? c) - (char-whitespace? c)) - (read-char in) - (loop))))) - - ;; lex-pcdata : Input-port (-> Location) -> Pcdata - ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec - (define (lex-pcdata in pos) - (let ([start (pos)] - [data (let loop () - (let ([next (peek-char-or-special in)]) - (cond - [(or (eof-object? next) - (not (char? next)) - (eq? next #\&) - (eq? next #\<)) - null] - [(and (char-whitespace? next) (collapse-whitespace)) - (skip-space in) - (cons #\space (loop))] - [else (cons (read-char in) (loop))])))]) - (make-pcdata start - (pos) - (list->string data)))) - - ;; lex-name : Input-port (-> Location) -> Symbol - (define (lex-name in pos) - (let ([c (non-eof read-char-or-special in pos)]) - (unless (name-start? c) - (lex-error in pos "expected name, received ~e" c)) - (string->symbol - (list->string - (cons c (let lex-rest () - (let ([c (non-eof peek-char-or-special in pos)]) - (cond - [(eq? c 'special) - (lex-error in pos "names cannot contain non-text values")] - [(name-char? c) - (cons (read-char in) (lex-rest))] - [else null])))))))) - - ;; skip-dtd : Input-port (-> Location) -> Void - (define (skip-dtd in pos) - (let skip () - (case (non-eof read-char in pos) - [(#\') (read-until #\' in pos) (skip)] - [(#\") (read-until #\" in pos) (skip)] - [(#\<) - (case (non-eof read-char in pos) - [(#\!) (case (non-eof read-char in pos) - [(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)] - [else (skip) (skip)])] - [(#\?) (lex-pi-data in pos) (skip)] - [else (skip) (skip)])] - [(#\>) (void)] - [else (skip)]))) - - ;; name-start? : Char -> Bool - (define (name-start? ch) - (and (char? ch) - (or (char-alphabetic? ch) - (eq? ch #\_) - (eq? ch #\:)))) - - ;; name-char? : Char -> Bool - (define (name-char? ch) - (and (char? ch) - (or (name-start? ch) - (char-numeric? ch) - (eq? ch #\.) - (eq? ch #\-)))) - - ;; read-until : Char Input-port (-> Location) -> String - ;; discards the stop character, too - (define (read-until char in pos) + (loop))))) + + ;; lex-pcdata : Input-port (-> Location) -> Pcdata + ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec + (define (lex-pcdata in pos) + (let ([start (pos)] + [data (let loop () + (let ([next (peek-char-or-special in)]) + (cond + [(or (eof-object? next) + (not (char? next)) + (eq? next #\&) + (eq? next #\<)) + null] + [(and (char-whitespace? next) (collapse-whitespace)) + (skip-space in) + (cons #\space (loop))] + [else (cons (read-char in) (loop))])))]) + (make-pcdata start + (pos) + (list->string data)))) + + ;; lex-name : Input-port (-> Location) -> Symbol + (define (lex-name in pos) + (let ([c (non-eof read-char-or-special in pos)]) + (unless (name-start? c) + (lex-error in pos "expected name, received ~e" c)) + (string->symbol + (list->string + (cons c (let lex-rest () + (let ([c (non-eof peek-char-or-special in pos)]) + (cond + [(eq? c 'special) + (lex-error in pos "names cannot contain non-text values")] + [(name-char? c) + (cons (read-char in) (lex-rest))] + [else null])))))))) + + ;; skip-dtd : Input-port (-> Location) -> Void + (define (skip-dtd in pos) + (let skip () + (case (non-eof read-char in pos) + [(#\') (read-until #\' in pos) (skip)] + [(#\") (read-until #\" in pos) (skip)] + [(#\<) + (case (non-eof read-char in pos) + [(#\!) (case (non-eof read-char in pos) + [(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)] + [else (skip) (skip)])] + [(#\?) (lex-pi-data in pos) (skip)] + [else (skip) (skip)])] + [(#\>) (void)] + [else (skip)]))) + + ;; name-start? : Char -> Bool + (define (name-start? ch) + (and (char? ch) + (or (char-alphabetic? ch) + (eq? ch #\_) + (eq? ch #\:)))) + + ;; name-char? : Char -> Bool + (define (name-char? ch) + (and (char? ch) + (or (name-start? ch) + (char-numeric? ch) + (eq? ch #\.) + (eq? ch #\-)))) + + ;; read-until : Char Input-port (-> Location) -> String + ;; discards the stop character, too + (define (read-until char in pos) + (list->string + (let read-more () + (let ([c (non-eof read-char in pos)]) + (cond + [(eq? c char) null] + [else (cons c (read-more))]))))) + + ;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char + (define (non-eof f in pos) + (let ([c (f in)]) + (cond + [(eof-object? c) (lex-error in pos "unexpected eof")] + [else c]))) + + ;; gen-read-until-string : String -> Input-port (-> Location) -> String + ;; uses Knuth-Morris-Pratt from + ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 + ;; discards stop from input + (define (gen-read-until-string stop) + (let* ([len (string-length stop)] + [prefix (make-vector len 0)] + [fall-back + (lambda (k c) + (let ([k (let loop ([k k]) + (cond + [(and (> k 0) (not (eq? (string-ref stop k) c))) + (loop (vector-ref prefix (sub1 k)))] + [else k]))]) + (if (eq? (string-ref stop k) c) + (add1 k) + k)))]) + (let init ([k 0] [q 1]) + (when (< q len) + (let ([k (fall-back k (string-ref stop q))]) + (vector-set! prefix q k) + (init k (add1 q))))) + ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop + (lambda (in pos) (list->string - (let read-more () - (let ([c (non-eof read-char in pos)]) - (cond - [(eq? c char) null] - [else (cons c (read-more))]))))) - - ;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char - (define (non-eof f in pos) - (let ([c (f in)]) - (cond - [(eof-object? c) (lex-error in pos "unexpected eof")] - [else c]))) - - ;; gen-read-until-string : String -> Input-port (-> Location) -> String - ;; uses Knuth-Morris-Pratt from - ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 - ;; discards stop from input - (define (gen-read-until-string stop) - (let* ([len (string-length stop)] - [prefix (make-vector len 0)] - [fall-back - (lambda (k c) - (let ([k (let loop ([k k]) - (cond - [(and (> k 0) (not (eq? (string-ref stop k) c))) - (loop (vector-ref prefix (sub1 k)))] - [else k]))]) - (if (eq? (string-ref stop k) c) - (add1 k) - k)))]) - (let init ([k 0] [q 1]) - (when (< q len) - (let ([k (fall-back k (string-ref stop q))]) - (vector-set! prefix q k) - (init k (add1 q))))) - ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop - (lambda (in pos) - (list->string - (let/ec out - (let loop ([matched 0] [out out]) - (let* ([c (non-eof read-char in pos)] - [matched (fall-back matched c)]) - (cond - [(= matched len) (out null)] - [(zero? matched) (cons c (let/ec out (loop matched out)))] - [else (cons c (loop matched out))])))))))) - - ;; "-->" makes more sense, but "--" follows the spec. - (define lex-comment-contents (gen-read-until-string "--")) - (define lex-pi-data (gen-read-until-string "?>")) - (define lex-cdata-contents (gen-read-until-string "]]>")) - - ;; positionify : Input-port -> Input-port (-> Location) - ; This function predates port-count-lines! and port-next-location. - ; Otherwise I would have used those directly at the call sites. - (define (positionify in) - (port-count-lines! in) - (values - in - (lambda () - (let-values ([(line column offset) (port-next-location in)]) - (make-location line column offset))))) - - ;; locs : (listof (list number number)) - (define-struct (exn:xml exn:fail:read) ()) - - ;; lex-error : Input-port String (-> Location) TST* -> alpha - ;; raises a lexer error, using exn:xml - (define (lex-error in pos str . rest) - (let* ([the-pos (pos)] - [offset (location-offset the-pos)]) - (raise - (make-exn:xml - (format "read-xml: lex-error: at position ~a: ~a" - (format-source the-pos) - (apply format str rest)) - (current-continuation-marks) - (list - (make-srcloc (object-name in) #f #f offset 1)))))) - - ;; parse-error : (listof srcloc) (listof TST) *-> alpha - ;; raises a parsing error, using exn:xml - (define (parse-error src fmt . args) - (raise (make-exn:xml (string-append "read-xml: parse-error: " - (apply format fmt args)) - (current-continuation-marks) - src))) - - ;; format-source : Location -> string - ;; to format the source location for an error message - (define (format-source loc) - (if (location? loc) - (format "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc)) - (format "~a" loc)))))) + (let/ec out + (let loop ([matched 0] [out out]) + (let* ([c (non-eof read-char in pos)] + [matched (fall-back matched c)]) + (cond + [(= matched len) (out null)] + [(zero? matched) (cons c (let/ec out (loop matched out)))] + [else (cons c (loop matched out))])))))))) + + ;; "-->" makes more sense, but "--" follows the spec. + (define lex-comment-contents (gen-read-until-string "--")) + (define lex-pi-data (gen-read-until-string "?>")) + (define lex-cdata-contents (gen-read-until-string "]]>")) + + ;; positionify : Input-port -> Input-port (-> Location) + ; This function predates port-count-lines! and port-next-location. + ; Otherwise I would have used those directly at the call sites. + (define (positionify in) + (port-count-lines! in) + (values + in + (lambda () + (let-values ([(line column offset) (port-next-location in)]) + (make-location line column offset))))) + + ;; locs : (listof (list number number)) + (define-struct (exn:xml exn:fail:read) ()) + + ;; lex-error : Input-port String (-> Location) TST* -> alpha + ;; raises a lexer error, using exn:xml + (define (lex-error in pos str . rest) + (let* ([the-pos (pos)] + [offset (location-offset the-pos)]) + (raise + (make-exn:xml + (format "read-xml: lex-error: at position ~a: ~a" + (format-source the-pos) + (apply format str rest)) + (current-continuation-marks) + (list + (make-srcloc (object-name in) #f #f offset 1)))))) + + ;; parse-error : (listof srcloc) (listof TST) *-> alpha + ;; raises a parsing error, using exn:xml + (define (parse-error src fmt . args) + (raise (make-exn:xml (string-append "read-xml: parse-error: " + (apply format fmt args)) + (current-continuation-marks) + src))) + + ;; format-source : Location -> string + ;; to format the source location for an error message + (define (format-source loc) + (if (location? loc) + (format "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc)) + (format "~a" loc)))) diff --git a/collects/xml/private/sig.ss b/collects/xml/private/sig.ss index 69da82bb3d..17498e8355 100644 --- a/collects/xml/private/sig.ss +++ b/collects/xml/private/sig.ss @@ -1,62 +1,89 @@ +#lang scheme -(module sig mzscheme - (require mzlib/unitsig) +(define-signature xml-structs^ + ((struct/ctc location ([line exact-nonnegative-integer?] + [char exact-nonnegative-integer?] + [offset exact-nonnegative-integer?])) + (struct/ctc source ([start (or/c location? symbol?)] + [stop (or/c location? symbol?)])) + (struct/ctc comment ([text string?])) + (struct pcdata (string)) ; XXX needs parent + (struct cdata (string)) ; XXX needs parent + (struct/ctc document-type ([name symbol?] + #;[external external-dtd?] + ; XXX results in this error + ; ->: expected contract or a value that can be coerced into one, got # + ; I presume that there is a letrec somewhere + [external any/c] + [inlined false/c])) + (struct/ctc document (#;[prolog prolog?] ; XXX same as above + [prolog any/c] + #;[element element?] + [element any/c] + #;[misc (listof (or/c comment? pi?))] + [misc (listof any/c)])) + (struct/ctc prolog (#;[misc (listof (or/c comment? pi?))] ; XXX same as above + [misc (listof any/c)] + #;[dtd document-type?] + [dtd any/c] + #;[misc2 (listof (or/c comment? pi?))] + [misc2 (listof any/c)])) + (struct/ctc external-dtd ([system string?])) + (struct external-dtd/public (public)) ; XXX needs parent + (struct external-dtd/system ()) ; XXX needs parent + (struct element (name attributes content)) ; XXX needs parent + (struct attribute (name value)) ; XXX needs parent + (struct pi (target-name instruction)) ; XXX needs parent + (struct entity (text)) ; XXX needs parent + (contracted + [content? (any/c . -> . boolean?)]))) - (define-signature xml-structs^ - ((struct location (line char offset)) - (struct document (prolog element misc)) - (struct comment (text)) - (struct prolog (misc dtd misc2)) - (struct document-type (name external inlined)) - (struct external-dtd (system)) - (struct external-dtd/public (public)) - (struct external-dtd/system ()) - (struct element (name attributes content)) - (struct attribute (name value)) - (struct pi (target-name instruction)) - (struct source (start stop)) - (struct pcdata (string)) - (struct cdata (string)) - (struct entity (text)) - content?)) +(define-signature writer^ + ((contracted + [write-xml ((any/c) (output-port?) . ->* . void?)] + [display-xml ((any/c) (output-port?) . ->* . void?)] + [write-xml/content ((any/c) (output-port?) . ->* . void?)] + [display-xml/content ((any/c) (output-port?) . ->* . void?)]) + ; XXX I can't contract the above (well), because they refer to structs from xml-structs^ + (contracted + [empty-tag-shorthand (parameter/c (or/c (symbols 'always 'never) (listof symbol?)))] + [html-empty-tags (listof symbol?)]))) - (define-signature writer^ - (write-xml - display-xml - write-xml/content - display-xml/content - empty-tag-shorthand - html-empty-tags)) +(define-signature reader^ + ((contracted + [read-xml (() (input-port?) . ->* . any/c)] + [read-xml/element (() (input-port?) . ->* . any/c)] + [read-comments (parameter/c boolean?)] + [collapse-whitespace (parameter/c boolean?)]) + ; XXX can't contract the above (well) because they refer to structs + ; XXX can't contract exn:xml beacuse of parent + (struct exn:xml ()))) - (define-signature reader^ - (read-xml - read-xml/element - read-comments - collapse-whitespace - (struct exn:xml ()))) +(define-signature xexpr^ + ((struct exn:invalid-xexpr (code)) ; XXX needs parent + (contracted + [xexpr/c contract?] + [xexpr? (any/c . -> . boolean?)] + [xexpr->string (xexpr/c . -> . string?)] + [xml->xexpr (any/c . -> . xexpr/c)] ; XXX bad because of struct + [xexpr->xml (xexpr/c . -> . any/c)] ; XXX bad because of struct + [xexpr-drop-empty-attributes (parameter/c boolean?)] + [permissive? (parameter/c boolean?)] + [validate-xexpr (any/c . -> . (one-of/c #t))] + [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)] + [xexpr-attribute? (any/c . -> . boolean?)] + [listof? ((any/c . -> . boolean?) any/c . -> . boolean?)] + [attribute->srep (any/c . -> . xexpr-attribute?)] ; XXX bad because of struct + [bcompose ((any/c any/c . -> . any/c) (any/c . -> . any/c) . -> . (any/c any/c . -> . any/c))] + [assoc-sort ((listof (list/c symbol? string?)) . -> . (listof (list/c symbol? string?)))]))) - (define-signature xexpr^ - (xml->xexpr - xexpr->xml - xexpr->string - xexpr-drop-empty-attributes - xexpr/c - xexpr? - permissive? - correct-xexpr? - validate-xexpr - (struct exn:invalid-xexpr (code)) - xexpr-attribute? - listof?)) +(define-signature space^ + ((contracted + ; XXX bad because of struct + [eliminate-whitespace ((listof symbol?) (boolean? . -> . boolean?) . -> . (any/c . -> . any/c))]))) - (define-signature extra-xexpr^ - ((open xexpr^) assoc-sort bcompose attribute->srep)) - - (define-signature space^ (eliminate-whitespace)) - - (provide xml-structs^ - writer^ - reader^ - xexpr^ - extra-xexpr^ - space^)) +(provide xml-structs^ + writer^ + reader^ + xexpr^ + space^) diff --git a/collects/xml/private/space.ss b/collects/xml/private/space.ss index dc7444623a..24e24b2891 100644 --- a/collects/xml/private/space.ss +++ b/collects/xml/private/space.ss @@ -1,39 +1,34 @@ +#lang scheme +(require "sig.ss") -(module space mzscheme - (require mzlib/unitsig - mzlib/list) - - (require "sig.ss") - - (provide space@) - - (define space@ - (unit/sig space^ - (import xml-structs^) - - ;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element - (define (eliminate-whitespace special eliminate-special?) - (letrec ([blank-it - (lambda (el) - (let ([name (element-name el)] - [content (map (lambda (x) - (if (element? x) (blank-it x) x)) - (element-content el))]) - (make-element - (source-start el) - (source-stop el) - name - (element-attributes el) - (cond - [(eliminate-special? (memq (element-name el) special)) - (filter (lambda (s) - (not (and (pcdata? s) - (or (all-blank (pcdata-string s)) - (error 'eliminate-blanks "Element <~a> is not allowed to contain text ~e" name (pcdata-string s)))))) - content)] - [else content]))))]) - blank-it)) - - ;; all-blank : String -> Bool - (define (all-blank s) (andmap char-whitespace? (string->list s)))))) +(provide space@) +(define-unit space@ + (import xml-structs^) + (export space^) + + ;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element + (define (eliminate-whitespace special eliminate-special?) + (letrec ([blank-it + (lambda (el) + (let ([name (element-name el)] + [content (map (lambda (x) + (if (element? x) (blank-it x) x)) + (element-content el))]) + (make-element + (source-start el) + (source-stop el) + name + (element-attributes el) + (cond + [(eliminate-special? (and (memq (element-name el) special) #t)) + (filter (lambda (s) + (not (and (pcdata? s) + (or (all-blank (pcdata-string s)) + (error 'eliminate-blanks "Element <~a> is not allowed to contain text ~e" name (pcdata-string s)))))) + content)] + [else content]))))]) + blank-it)) + + ;; all-blank : String -> Bool + (define (all-blank s) (andmap char-whitespace? (string->list s)))) diff --git a/collects/xml/private/structures.ss b/collects/xml/private/structures.ss index e2bb74bd55..c939b0cf68 100644 --- a/collects/xml/private/structures.ss +++ b/collects/xml/private/structures.ss @@ -1,86 +1,71 @@ +#lang scheme +(require "sig.ss") -(module structures mzscheme - (require mzlib/unitsig) +(provide xml-structs@) - (require "sig.ss") - - (provide xml-structs@) - - (define xml-structs@ - (unit/sig xml-structs^ - (import) - - ; Location = (make-location Nat Nat Nat) | Symbol - (define-struct location (line char offset)) - - ; Source = (make-source Location Location) - (define-struct source (start stop)) - - ; Document = (make-document Prolog Element (listof Misc)) - (define-struct document (prolog element misc)) - - ; Prolog = (make-prolog (listof Misc) Document-type [Misc ...]) - ; The Misc items after the Document-type are optional arguments to maintain - ; backward compatability with older versions of the XML library. - ;(define-struct prolog (misc dtd misc2)) - - (define-values (struct:prolog real-make-prolog prolog? access-prolog set-prolog!) - (make-struct-type 'prolog #f 3 0)) - - (define (make-prolog misc dtd . misc2) - (real-make-prolog misc dtd misc2)) - - (define prolog-misc (make-struct-field-accessor access-prolog 0 'misc)) - (define set-prolog-misc! (make-struct-field-mutator set-prolog! 0 'misc)) - - (define prolog-dtd (make-struct-field-accessor access-prolog 1 'dtd)) - (define set-prolog-dtd! (make-struct-field-mutator set-prolog! 1 'dtd)) - - (define prolog-misc2 (make-struct-field-accessor access-prolog 2 'misc2)) - (define set-prolog-misc2! (make-struct-field-mutator set-prolog! 2 'misc2)) - - ; Document-type = (make-document-type sym External-dtd #f) - ; | #f - (define-struct document-type (name external inlined)) - - ; External-dtd = (make-external-dtd/public str str) - ; | (make-external-dtd/system str) - ; | #f - (define-struct external-dtd (system)) - (define-struct (external-dtd/public external-dtd) (public)) - (define-struct (external-dtd/system external-dtd) ()) - - ; Element = (make-element Location Location Symbol (listof Attribute) (listof Content)) - (define-struct (element source) (name attributes content)) - - ; Attribute = (make-attribute Location Location Symbol String) - (define-struct (attribute source) (name value)) - - ; Pcdata = (make-pcdata Location Location String) - (define-struct (pcdata source) (string)) - - ; Cdata = (make-cdata Location Location String) - (define-struct (cdata source) (string)) - - ; Content = Pcdata - ; | Element - ; | Entity - ; | Misc - ; | Cdata - - ; Misc = Comment - ; | Processing-instruction - - ; Entity = (make-entity Location Location (U Nat Symbol)) - (define-struct (entity source) (text)) - - ; Processing-instruction = (make-pi Location Location String String) - ; also represents XMLDecl - (define-struct (pi source) (target-name instruction)) - - ; Comment = (make-comment String) - (define-struct comment (text)) - - ; content? : TST -> Bool - (define (content? x) - (or (pcdata? x) (element? x) (entity? x) (comment? x) (pi? x)))))) +(define-unit xml-structs@ + (import) + (export xml-structs^) + + ; Location = (make-location Nat Nat Nat) | Symbol + (define-struct location (line char offset)) + + ; Source = (make-source Location Location) + (define-struct source (start stop)) + + ; Document = (make-document Prolog Element (listof Misc)) + (define-struct document (prolog element misc)) + + ; Prolog = (make-prolog (listof Misc) Document-type (listof Misc)) + (define-struct prolog (misc dtd misc2)) + + ; Document-type = (make-document-type sym External-dtd #f) + ; | #f + (define-struct document-type (name external inlined)) + + ; External-dtd = (make-external-dtd/public str str) + ; | (make-external-dtd/system str) + ; | #f + (define-struct external-dtd (system)) + (define-struct (external-dtd/public external-dtd) (public)) + (define-struct (external-dtd/system external-dtd) ()) + + ; Element = (make-element Location Location Symbol (listof Attribute) (listof Content)) + (define-struct (element source) (name attributes content)) + + ; Attribute = (make-attribute Location Location Symbol String) + (define-struct (attribute source) (name value)) + + ; Pcdata = (make-pcdata Location Location String) + (define-struct (pcdata source) (string)) + + ; Cdata = (make-cdata Location Location String) + (define-struct (cdata source) (string)) + + ; Content = Pcdata + ; | Element + ; | Entity + ; | Misc + ; | Cdata + + ; Misc = Comment + ; | Processing-instruction + + ; Entity = (make-entity Location Location (U Nat Symbol)) + (define-struct (entity source) (text)) + + ; Processing-instruction = (make-pi Location Location String String) + ; also represents XMLDecl + (define-struct (pi source) (target-name instruction)) + + ; Comment = (make-comment String) + (define-struct comment (text)) + + ; content? : TST -> Bool + (define (content? x) + (or (pcdata? x) + (element? x) + (entity? x) + (comment? x) + (cdata? x) + (pi? x)))) diff --git a/collects/xml/private/syntax.ss b/collects/xml/private/syntax.ss index 222833f99f..6b03e9e91f 100644 --- a/collects/xml/private/syntax.ss +++ b/collects/xml/private/syntax.ss @@ -1,213 +1,212 @@ -(module syntax mzscheme - (provide syntax-structs@) - (require mzlib/unitsig - "sig.ss") +#lang scheme +(require "sig.ss") + +; to make error-raising functions named like structure mutators +(define-syntax (struct! stx) + (syntax-case stx () + [(struct-src name (field ...)) + (with-syntax ([struct:name (datum->syntax + (syntax name) + (string->symbol (string-append "struct:" (symbol->string (syntax->datum (syntax name))))))] + [(setter-name ...) + (let ([struct-name + (symbol->string (syntax->datum (syntax name)))]) + (map (lambda (field-name) + (datum->syntax + field-name + (string->symbol + (string-append + "set-" + struct-name + "-" + (symbol->string (syntax->datum field-name)) + "!")))) + (syntax->list (syntax (field ...)))))]) + (syntax + (begin + (define struct:name void) + (define (setter-name s v) + (error (quote setter-name) "cannot mutate XML syntax")) + ...)))])) + +(provide syntax-structs@) +(define-unit syntax-structs@ + (import) + (export xml-structs^) - ; to make error-raising functions named like structure mutators - (define-syntax (struct! stx) - (syntax-case stx () - [(struct-src name (field ...)) - (with-syntax ([struct:name (datum->syntax-object - (syntax name) - (string->symbol (string-append "struct:" (symbol->string (syntax-object->datum (syntax name))))))] - [(setter-name ...) - (let ([struct-name - (symbol->string (syntax-object->datum (syntax name)))]) - (map (lambda (field-name) - (datum->syntax-object - field-name - (string->symbol - (string-append - "set-" - struct-name - "-" - (symbol->string (syntax-object->datum field-name)) - "!")))) - (syntax->list (syntax (field ...)))))]) - (syntax - (begin - (define struct:name void) - (define (setter-name s v) - (error (quote setter-name) "cannot mutate XML syntax")) - ...)))])) + ; The locations from the two sets of structures shouldn't mingle, so I'm + ; re-defining the location structure. Maybe this is not a good idea, but I + ; think it's okay. + (define-struct location (line char offset)) + (define-struct source (start stop)) - (define syntax-structs@ - (unit/sig xml-structs^ - (import) - - ; The locations from the two sets of structures shouldn't mingle, so I'm - ; re-defining the location structure. Maybe this is not a good idea, but I - ; think it's okay. - (define-struct location (line char offset)) - (define-struct source (start stop)) - - ; make-document : prolog element ? -> document - (define (make-document p e ?) e) - - ; make-prolog : ? #f -> prolog - (define (make-prolog ? ??) #f) - - ; make-element : src src sym (listof attribute) (listof content) -> element - (define (make-element from to name attrs content) - (wrap (list* name attrs content) from to)) - - ; make-pcdata : src src str -> pcdata - (define (make-pcdata from to x) - (wrap x from to)) - - ; make-cdata : src src str -> cdata - (define (make-cdata from to x) - (wrap x from to)) - - ; make-entity : src src (U sym num) -> entity - (define (make-entity from to entity) - (wrap entity from to)) - - ; make-comment : str -> comment - ; There is no syntax object representation for comments - (define (make-comment x) #f) - - ; make-pi : src src sym str -> pi - ; There's not really a syntax object representation for pi's either - (define (make-pi from to name val) #f) - - ; make-attribute : src src sym str -> attribute - (define (make-attribute from to name val) - (wrap (list name val) from to)) - - (define (make-document-type . x) #f) - (define (make-external-dtd . x) #f) - (define (make-external-dtd/public . x) #f) - (define (make-external-dtd/system . x) #f) - - ; wrap : tst src src -> syntax - (define (wrap x from to) - (datum->syntax-object #f x (position from to))) - - ; position : src src -> (list #f nat nat nat nat) - (define (position from to) - (let ([start-offset (location-offset from)]) - (list #f (location-line from) (location-char from) start-offset - (- (location-offset to) start-offset)))) - - ; : syntax -> syntax - (define (attribute-name a) (car (syntax->list a))) - (define (attribute-value a) (cadr (syntax->list a))) - - ; : syntax -> syntax - (define (element-name e) (car (syntax->list e))) - (define (element-attributes e) (cadr (syntax->list e))) - (define (element-content e) (cddr (syntax->list e))) - - (define (entity-text e) (syntax-e e)) - - (define (pcdata-string x) (syntax-e x)) - (define (cdata-string x) (syntax-e x)) - - (define (comment-text c) - (error 'comment-text "expected a syntax representation of an XML comment, received ~e" c)) - ; conflate documents with their root elements - (define (document-element d) d) - ; more here - spoof document pieces better? - (define (document-misc d) null) - (define (document-prolog d) null) - - (define (document-type-external dtd) - (error 'document-type-external "expected a dtd, given ~e" dtd)) - - (define (document-type-inlined dtd) - (error 'document-type-inlined "expected a dtd, given ~e" dtd)) - - (define (document-type-name dtd) - (error 'document-type-name "expected a dtd, given ~e" dtd)) - - (define (external-dtd-system x) - (error 'external-dtd-system "expected an external dtd, given ~e" x)) - - (define (external-dtd/public-public x) - (error 'external-dtd/public-public "expected an external dtd, given ~e" x)) - - (define (pi-instruction x) - (error 'pi-instruction "expected a pi, given ~e" x)) - - (define (pi-target-name x) - (error 'pi-target-name "expected a pi, given ~e" x)) - - (define (prolog-dtd x) - (error 'prolog-dtd "expected a prolog, given ~e" x)) - - (define (prolog-misc x) - (error 'prolog-misc "expected a prolog, given ~e" x)) - - (define (prolog-misc2 x) - (error 'prolog-misc2 "expected a prolog, given ~e" x)) - - ; : tst -> bool - (define (attribute? a) - (and (syntax? a) - (let ([x (syntax-object->datum a)]) - (and (pair? x) (symbol? (car x)) - (pair? (cdr x)) (string? (cadr x)) - (null? (cddr x)))))) - - - ; : tst -> bool - (define (comment? x) #f) - - ; : tst -> bool - (define (content? x) - (and (syntax? x) - (or (string? (syntax-object->datum x)) - (element? x)))) - - ; : tst -> bool - (define (element? x) - (and (syntax? x) - (let ([e (syntax-e x)]) - (and (pair? e) (symbol? (car e)) - (pair? (cdr e)) (list? (cadr e)) - (andmap attribute? (cadr e)) - (list? (cddr e)) - (andmap content? (cddr e)))))) - - ; : tst -> bool - (define document? element?) - - ; : tst -> bool - (define (document-type? x) #f) - - ; : tst -> bool - (define (external-dtd/public? x) #f) - (define (external-dtd/system? x) #f) - (define (external-dtd? x) #f) - - (define (prolog? x) #f) - (define (pi? x) #f) - - ; : tst -> bool - (define (pcdata? x) - (and (syntax? x) (string (syntax-e x)))) - (define (cdata? x) - (and (syntax? x) (string (syntax-e x)))) - - ; : tst -> bool - (define (entity? x) - (and (syntax? x) (let ([r (syntax-e x)]) (or (symbol? r) (number? r))))) - - ;(struct! location (line char offset)) - (struct! document (prolog element misc)) - (struct! comment (text)) - (struct! prolog (misc dtd misc2)) - (struct! document-type (name external inlined)) - (struct! external-dtd (system)) - (struct! external-dtd/public (public)) - (struct! external-dtd/system ()) - (struct! element (name attributes content)) - (struct! attribute (name value)) - (struct! pi (target-name instruction)) - ;(struct! source (start stop)) - (struct! pcdata (string)) - (struct! cdata (string)) - (struct! entity (text)) - - ))) + ; make-document : prolog element ? -> document + (define (make-document p e ?) e) + + ; make-prolog : (listof Misc) Document-type (listof Misc) -> prolog + (define (make-prolog misc dtd misc2) #f) + + ; make-element : src src sym (listof attribute) (listof content) -> element + (define (make-element from to name attrs content) + (wrap (list* name attrs content) from to)) + + ; make-pcdata : src src str -> pcdata + (define (make-pcdata from to x) + (wrap x from to)) + + ; make-cdata : src src str -> cdata + (define (make-cdata from to x) + (wrap x from to)) + + ; make-entity : src src (U sym num) -> entity + (define (make-entity from to entity) + (wrap entity from to)) + + ; make-comment : str -> comment + ; There is no syntax object representation for comments + (define (make-comment x) #f) + + ; make-pi : src src sym str -> pi + ; There's not really a syntax object representation for pi's either + (define (make-pi from to name val) #f) + + ; make-attribute : src src sym str -> attribute + (define (make-attribute from to name val) + (wrap (list name val) from to)) + + (define (make-document-type . x) #f) + (define (make-external-dtd . x) #f) + (define (make-external-dtd/public . x) #f) + (define (make-external-dtd/system . x) #f) + + ; wrap : tst src src -> syntax + (define (wrap x from to) + (datum->syntax #f x (position from to))) + + ; position : src src -> (list #f nat nat nat nat) + (define (position from to) + (let ([start-offset (location-offset from)]) + (list #f (location-line from) (location-char from) start-offset + (- (location-offset to) start-offset)))) + + ; : syntax -> syntax + (define (attribute-name a) (car (syntax->list a))) + (define (attribute-value a) (cadr (syntax->list a))) + + ; : syntax -> syntax + (define (element-name e) (car (syntax->list e))) + (define (element-attributes e) (cadr (syntax->list e))) + (define (element-content e) (cddr (syntax->list e))) + + (define (entity-text e) (syntax-e e)) + + (define (pcdata-string x) (syntax-e x)) + (define (cdata-string x) (syntax-e x)) + + (define (comment-text c) + (error 'comment-text "expected a syntax representation of an XML comment, received ~e" c)) + ; conflate documents with their root elements + (define (document-element d) d) + ; more here - spoof document pieces better? + (define (document-misc d) null) + (define (document-prolog d) null) + + (define (document-type-external dtd) + (error 'document-type-external "expected a dtd, given ~e" dtd)) + + (define (document-type-inlined dtd) + (error 'document-type-inlined "expected a dtd, given ~e" dtd)) + + (define (document-type-name dtd) + (error 'document-type-name "expected a dtd, given ~e" dtd)) + + (define (external-dtd-system x) + (error 'external-dtd-system "expected an external dtd, given ~e" x)) + + (define (external-dtd/public-public x) + (error 'external-dtd/public-public "expected an external dtd, given ~e" x)) + + (define (pi-instruction x) + (error 'pi-instruction "expected a pi, given ~e" x)) + + (define (pi-target-name x) + (error 'pi-target-name "expected a pi, given ~e" x)) + + (define (prolog-dtd x) + (error 'prolog-dtd "expected a prolog, given ~e" x)) + + (define (prolog-misc x) + (error 'prolog-misc "expected a prolog, given ~e" x)) + + (define (prolog-misc2 x) + (error 'prolog-misc2 "expected a prolog, given ~e" x)) + + ; : tst -> bool + (define (attribute? a) + (and (syntax? a) + (let ([x (syntax->datum a)]) + (and (pair? x) (symbol? (car x)) + (pair? (cdr x)) (string? (cadr x)) + (null? (cddr x)))))) + + + ; : tst -> bool + (define (comment? x) #f) + + ; : tst -> bool + (define (content? x) + (and (syntax? x) + (or (string? (syntax->datum x)) + (element? x)))) + + ; : tst -> bool + (define (element? x) + (and (syntax? x) + (let ([e (syntax-e x)]) + (and (pair? e) (symbol? (car e)) + (pair? (cdr e)) (list? (cadr e)) + (andmap attribute? (cadr e)) + (list? (cddr e)) + (andmap content? (cddr e)))))) + + ; : tst -> bool + (define document? element?) + + ; : tst -> bool + (define (document-type? x) #f) + + ; : tst -> bool + (define (external-dtd/public? x) #f) + (define (external-dtd/system? x) #f) + (define (external-dtd? x) #f) + + (define (prolog? x) #f) + (define (pi? x) #f) + + ; : tst -> bool + (define (pcdata? x) + (and (syntax? x) (string (syntax-e x)))) + (define (cdata? x) + (and (syntax? x) (string (syntax-e x)))) + + ; : tst -> bool + (define (entity? x) + (and (syntax? x) (let ([r (syntax-e x)]) (or (symbol? r) (number? r))))) + + ;(struct! location (line char offset)) + (struct! document (prolog element misc)) + (struct! comment (text)) + (struct! prolog (misc dtd misc2)) + (struct! document-type (name external inlined)) + (struct! external-dtd (system)) + (struct! external-dtd/public (public)) + (struct! external-dtd/system ()) + (struct! element (name attributes content)) + (struct! attribute (name value)) + (struct! pi (target-name instruction)) + ;(struct! source (start stop)) + (struct! pcdata (string)) + (struct! cdata (string)) + (struct! entity (text)) + + ) diff --git a/collects/xml/private/writer.ss b/collects/xml/private/writer.ss index c04aa39da6..f9e364f7c7 100644 --- a/collects/xml/private/writer.ss +++ b/collects/xml/private/writer.ss @@ -1,174 +1,167 @@ +#lang scheme +(require "sig.ss") -(module writer mzscheme - (require mzlib/unitsig - mzlib/list - mzlib/string - mzlib/etc - (only scheme/base for for/fold in-list log-error)) +(provide writer@) + +(define-unit writer@ + (import xml-structs^) + (export writer^) - (require "sig.ss") + ;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol)) + (define empty-tag-shorthand + (make-parameter 'always + (lambda (x) + (if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x))) + x + (error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~e" x))))) - (provide writer@) + (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area)) - (define writer@ - (unit/sig writer^ - (import xml-structs^) - - ;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol)) - (define empty-tag-shorthand - (make-parameter 'always - (lambda (x) - (if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x))) - x - (error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~e" x))))) - - (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area)) - - ;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void - (define (gen-write/display-xml/content dent) - (opt-lambda (c [out (current-output-port)]) (write-xml-content c 0 dent out))) - - ;; indent : Nat Output-port -> Void - (define (indent n out) - (newline out) - (let loop ([n n]) - (unless (zero? n) - (display #\space out) - (loop (sub1 n))))) - - ;; write-xml/content : Content [Output-port] -> Void - (define write-xml/content (gen-write/display-xml/content void)) - - ;; display-xml/content : Content [Output-port] -> Void - (define display-xml/content (gen-write/display-xml/content indent)) - - ;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void - (define (gen-write/display-xml output-content) - (opt-lambda (doc [out (current-output-port)]) - (let ([prolog (document-prolog doc)]) - (display-outside-misc (prolog-misc prolog) out) - (display-dtd (prolog-dtd prolog) out) - (display-outside-misc (prolog-misc2 prolog) out)) - (output-content (document-element doc) out) - (display-outside-misc (document-misc doc) out))) - - ; display-dtd : document-type oport -> void - (define (display-dtd dtd out) - (when dtd - (fprintf out "" out) - (newline out))) - - ;; write-xml : Document [Output-port] -> Void - (define write-xml (gen-write/display-xml write-xml/content)) - - ;; display-xml : Document [Output-port] -> Void - (define display-xml (gen-write/display-xml display-xml/content)) - - ;; display-outside-misc : (listof Misc) Output-port -> Void - (define (display-outside-misc misc out) - (for-each (lambda (x) - ((cond - [(comment? x) write-xml-comment] - [(pi? x) write-xml-pi]) x 0 void out) - (newline out)) - misc)) - - ;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-content el over dent out) - ((cond - [(element? el) write-xml-element] - [(pcdata? el) write-xml-pcdata] - [(cdata? el) write-xml-cdata] - [(entity? el) write-xml-entity] - [(comment? el) write-xml-comment] - [(pi? el) write-xml-pi] - [else (error 'write-xml-content "received ~e" el)]) - el over dent out)) - - ;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-element el over dent out) - (let* ([name (element-name el)] - [start (lambda (str) - (write-xml-base str over dent out) - (display name out))] - [content (element-content el)]) - (start "<") - (for ([att (in-list (element-attributes el))]) - (fprintf out " ~a=\"~a\"" (attribute-name att) - (escape (attribute-value att) escape-attribute-table))) - (if (and (null? content) - (let ([short (empty-tag-shorthand)]) - (case short - [(always) #t] - [(never) #f] - [else (memq (lowercase-symbol name) short)]))) - (display " />" out) - (begin - (display ">" out) - (for ([c (in-list content)]) - (write-xml-content c (incr over) dent out)) - (start "" out))))) - - ; : sym -> sym - (define lowercases (make-hash-table 'weak)) - (define (lowercase-symbol x) - (or (hash-table-get lowercases x #f) - (let ([s (symbol->string x)]) - (let ([s (string->symbol (string-downcase s))]) - (hash-table-put! lowercases x s) - s)))) - - ;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-base el over dent out) - (dent over out) - (display el out)) - - ;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-pcdata str over dent out) - (write-xml-base (escape (pcdata-string str) escape-table) over dent out)) - - ;; write-xml-cdata : Cdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-cdata cdata over dent out) - ;; XXX: Different kind of quote is needed, for assume the user includes the with proper quoting - (write-xml-base (format "~a" (cdata-string cdata)) over dent out)) - - ;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-pi pi over dent out) - (write-xml-base (format "" (pi-target-name pi) (pi-instruction pi)) over dent out)) - - ;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-comment comment over dent out) - (write-xml-base (format "" (comment-text comment)) over dent out)) - - ;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void - (define (write-xml-entity entity over dent out) - (let ([n (entity-text entity)]) - (fprintf out (if (number? n) "&#~a;" "&~a;") n))) - - (define escape-table #rx"[<>&]") - (define escape-attribute-table #rx"[<>&\"]") - - (define (replace-escaped s) - (case (string-ref s 0) - [(#\<) "<"] - [(#\>) ">"] - [(#\&) "&"] - [(#\") """])) - - ;; escape : String -> String - (define (escape x table) - (regexp-replace* table x replace-escaped)) - - ;; incr : Nat -> Nat - (define (incr n) (+ n 2))))) + ;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void + (define (gen-write/display-xml/content dent) + (lambda (c [out (current-output-port)]) (write-xml-content c 0 dent out))) + + ;; indent : Nat Output-port -> Void + (define (indent n out) + (newline out) + (let loop ([n n]) + (unless (zero? n) + (display #\space out) + (loop (sub1 n))))) + + ;; write-xml/content : Content [Output-port] -> Void + (define write-xml/content (gen-write/display-xml/content void)) + + ;; display-xml/content : Content [Output-port] -> Void + (define display-xml/content (gen-write/display-xml/content indent)) + + ;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void + (define (gen-write/display-xml output-content) + (lambda (doc [out (current-output-port)]) + (let ([prolog (document-prolog doc)]) + (display-outside-misc (prolog-misc prolog) out) + (display-dtd (prolog-dtd prolog) out) + (display-outside-misc (prolog-misc2 prolog) out)) + (output-content (document-element doc) out) + (display-outside-misc (document-misc doc) out))) + + ; display-dtd : document-type oport -> void + (define (display-dtd dtd out) + (when dtd + (fprintf out "" out) + (newline out))) + + ;; write-xml : Document [Output-port] -> Void + (define write-xml (gen-write/display-xml write-xml/content)) + + ;; display-xml : Document [Output-port] -> Void + (define display-xml (gen-write/display-xml display-xml/content)) + + ;; display-outside-misc : (listof Misc) Output-port -> Void + (define (display-outside-misc misc out) + (for-each (lambda (x) + ((cond + [(comment? x) write-xml-comment] + [(pi? x) write-xml-pi]) x 0 void out) + (newline out)) + misc)) + + ;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-content el over dent out) + ((cond + [(element? el) write-xml-element] + [(pcdata? el) write-xml-pcdata] + [(cdata? el) write-xml-cdata] + [(entity? el) write-xml-entity] + [(comment? el) write-xml-comment] + [(pi? el) write-xml-pi] + [else (error 'write-xml-content "received ~e" el)]) + el over dent out)) + + ;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-element el over dent out) + (let* ([name (element-name el)] + [start (lambda (str) + (write-xml-base str over dent out) + (display name out))] + [content (element-content el)]) + (start "<") + (for ([att (in-list (element-attributes el))]) + (fprintf out " ~a=\"~a\"" (attribute-name att) + (escape (attribute-value att) escape-attribute-table))) + (if (and (null? content) + (let ([short (empty-tag-shorthand)]) + (case short + [(always) #t] + [(never) #f] + [else (memq (lowercase-symbol name) short)]))) + (display " />" out) + (begin + (display ">" out) + (for ([c (in-list content)]) + (write-xml-content c (incr over) dent out)) + (start "" out))))) + + ; : sym -> sym + (define lowercases (make-weak-hash)) + (define (lowercase-symbol x) + (or (hash-ref lowercases x #f) + (let ([s (symbol->string x)]) + (let ([s (string->symbol (string-downcase s))]) + (hash-set! lowercases x s) + s)))) + + ;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-base el over dent out) + (dent over out) + (display el out)) + + ;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-pcdata str over dent out) + (write-xml-base (escape (pcdata-string str) escape-table) over dent out)) + + ;; write-xml-cdata : Cdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-cdata cdata over dent out) + ;; XXX: Different kind of quote is needed, for assume the user includes the with proper quoting + (write-xml-base (format "~a" (cdata-string cdata)) over dent out)) + + ;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-pi pi over dent out) + (write-xml-base (format "" (pi-target-name pi) (pi-instruction pi)) over dent out)) + + ;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-comment comment over dent out) + (write-xml-base (format "" (comment-text comment)) over dent out)) + + ;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void + (define (write-xml-entity entity over dent out) + (let ([n (entity-text entity)]) + (fprintf out (if (number? n) "&#~a;" "&~a;") n))) + + (define escape-table #rx"[<>&]") + (define escape-attribute-table #rx"[<>&\"]") + + (define (replace-escaped s) + (case (string-ref s 0) + [(#\<) "<"] + [(#\>) ">"] + [(#\&) "&"] + [(#\") """])) + + ;; escape : String -> String + (define (escape x table) + (regexp-replace* table x replace-escaped)) + + ;; incr : Nat -> Nat + (define (incr n) (+ n 2))) diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index 05ec921117..c2c6954365 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -1,231 +1,228 @@ -(module xexpr mzscheme - (require mzlib/unitsig - mzlib/list - scheme/contract - scheme/pretty - mzlib/etc) +#lang scheme +(require scheme/pretty) +(require "sig.ss") + +(provide xexpr@) + +(define-unit xexpr@ + (import xml-structs^ writer^) + (export xexpr^) + ;; Xexpr ::= String + ;; | (list* Symbol (listof Attribute-srep) (listof Xexpr)) + ;; | (cons Symbol (listof Xexpr)) + ;; | Symbol + ;; | Nat + ;; | Comment + ;; | Processing-instruction + ;; | Cdata + ;; Attribute-srep ::= (list Symbol String) - (require "sig.ss") + ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts. - (provide xexpr@) + ;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a)) + (define (assoc-sort to-sort) + (sort to-sort (bcompose stringstring car)))) - (define xexpr@ - (unit/sig extra-xexpr^ - (import xml-structs^ writer^) - ;; Xexpr ::= String - ;; | (list* Symbol (listof Attribute-srep) (listof Xexpr)) - ;; | (cons Symbol (listof Xexpr)) - ;; | Symbol - ;; | Nat - ;; | Comment - ;; | Processing-instruction - ;; | Cdata - ;; Attribute-srep ::= (list Symbol String) - - ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts. - - ;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a)) - (define (assoc-sort to-sort) - (sort to-sort (bcompose stringstring car)))) - - (define xexpr-drop-empty-attributes (make-parameter #f)) - - (define xexpr/c - (make-proj-contract - 'xexpr? - (lambda (pos neg src-info name) - (lambda (val) - (with-handlers ([exn:invalid-xexpr? - (lambda (exn) - (raise-contract-error - val - src-info - pos - name - "Not an Xexpr. ~a~n~nContext:~n~a" - (exn-message exn) - (pretty-format val)))]) - (validate-xexpr val) - val))) - (lambda (v) #t))) - - (define (xexpr? x) - (correct-xexpr? x (lambda () #t) (lambda (exn) #f))) - - - (define (validate-xexpr x) - (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn)))) - - ;; ;; ;; ;; ;; ;; ; - ;; ; xexpr? helpers - - (define-struct (exn:invalid-xexpr exn:fail) (code)) - - ;; correct-xexpr? : any (-> a) (exn -> a) -> a - (define (correct-xexpr? x true false) - (cond - ((string? x) (true)) - ((symbol? x) (true)) - ((exact-nonnegative-integer? x) (true)) - ((comment? x) (true)) - ((pi? x) (true)) - ((cdata? x) (true)) - ((list? x) - (or (null? x) - (if (symbol? (car x)) - (if (has-attribute? x) - (and (attribute-pairs? (cadr x) true false) - (andmap (lambda (part) - (correct-xexpr? part true false)) - (cddr x)) - (true)) - (andmap (lambda (part) - (correct-xexpr? part true false)) - (cdr x))) - (false (make-exn:invalid-xexpr - (format - "Expected a symbol as the element name, given ~s" - (car x)) - (current-continuation-marks) - x))))) - (else (false - (make-exn:invalid-xexpr - (format (string-append - "Expected a string, symbol, number, comment, " - "processing instruction, or list, given ~s") - x) - (current-continuation-marks) - x))))) - - ;; has-attribute? : List -> Boolean - ;; True if the Xexpr provided has an attribute list. - (define (has-attribute? x) - (and (> (length x) 1) - (list? (cadr x)) - (andmap (lambda (attr) - (pair? attr)) - (cadr x)))) - - ;; attribute-pairs? : List (-> a) (exn -> a) -> a - ;; True if the list is a list of pairs. - (define (attribute-pairs? attrs true false) - (if (null? attrs) + (define xexpr-drop-empty-attributes (make-parameter #f)) + + (define xexpr/c + (make-proj-contract + 'xexpr? + (lambda (pos neg src-info name) + (lambda (val) + (with-handlers ([exn:invalid-xexpr? + (lambda (exn) + (raise-contract-error + val + src-info + pos + name + "Not an Xexpr. ~a~n~nContext:~n~a" + (exn-message exn) + (pretty-format val)))]) + (validate-xexpr val) + val))) + (lambda (v) #t))) + + (define (xexpr? x) + (correct-xexpr? x (lambda () #t) (lambda (exn) #f))) + + + (define (validate-xexpr x) + (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn)))) + + ;; ;; ;; ;; ;; ;; ; + ;; ; xexpr? helpers + + (define-struct (exn:invalid-xexpr exn:fail) (code)) + + ;; correct-xexpr? : any (-> a) (exn -> a) -> a + (define (correct-xexpr? x true false) + (cond + ((string? x) (true)) + ((symbol? x) (true)) + ((exact-nonnegative-integer? x) (true)) + ((comment? x) (true)) + ((pi? x) (true)) + ((cdata? x) (true)) + ((pcdata? x) (true)) + ((list? x) + (or (null? x) + (if (symbol? (car x)) + (if (has-attribute? x) + (and (attribute-pairs? (cadr x) true false) + (andmap (lambda (part) + (correct-xexpr? part true false)) + (cddr x)) + (true)) + (andmap (lambda (part) + (correct-xexpr? part true false)) + (cdr x))) + (false (make-exn:invalid-xexpr + (format + "Expected a symbol as the element name, given ~s" + (car x)) + (current-continuation-marks) + x))))) + [(permissive?) (true)] + (else (false + (make-exn:invalid-xexpr + (format (string-append + "Expected a string, symbol, number, comment, " + "processing instruction, or list, given ~s") + x) + (current-continuation-marks) + x))))) + + ;; has-attribute? : List -> Boolean + ;; True if the Xexpr provided has an attribute list. + (define (has-attribute? x) + (and (> (length x) 1) + (list? (cadr x)) + (andmap (lambda (attr) + (pair? attr)) + (cadr x)))) + + ;; attribute-pairs? : List (-> a) (exn -> a) -> a + ;; True if the list is a list of pairs. + (define (attribute-pairs? attrs true false) + (if (null? attrs) + (true) + (let ((attr (car attrs))) + (if (pair? attr) + (and (attribute-symbol-string? attr true false) + (attribute-pairs? (cdr attrs) true false ) + (true)) + (false + (make-exn:invalid-xexpr + (format "Expected a pair, given ~a" attr) + (current-continuation-marks) + attr)))))) + + ;; attribute-symbol-string? : List (-> a) (exn -> a) -> a + ;; True if the list is a list of String,Symbol pairs. + (define (attribute-symbol-string? attr true false) + (if (symbol? (car attr)) + (if (string? (cadr attr)) (true) - (let ((attr (car attrs))) - (if (pair? attr) - (and (attribute-symbol-string? attr true false) - (attribute-pairs? (cdr attrs) true false ) - (true)) - (false - (make-exn:invalid-xexpr - (format "Expected a pair, given ~a" attr) - (current-continuation-marks) - attr)))))) - - ;; attribute-symbol-string? : List (-> a) (exn -> a) -> a - ;; True if the list is a list of String,Symbol pairs. - (define (attribute-symbol-string? attr true false) - (if (symbol? (car attr)) - (if (string? (cadr attr)) - (true) - (false (make-exn:invalid-xexpr - (format "Expected a string, given ~a" (cadr attr)) - (current-continuation-marks) - (cadr attr)))) (false (make-exn:invalid-xexpr - (format "Expected a symbol, given ~a" (car attr)) + (format "Expected a string, given ~a" (cadr attr)) (current-continuation-marks) - (cadr attr))))) - - ;; ; end xexpr? helpers - ;; ;; ;; ;; ;; ;; ;; ;; - - - ; : (a -> bool) tst -> bool - ; To check if l is a (listof p?) - ; Don't use (and (list? l) (andmap p? l)) because l may be improper. - (define (listof? p? l) - (let listof-p? ([l l]) - (or (null? l) - (and (cons? l) (p? (car l)) (listof-p? (cdr l)))))) - - ; : tst -> bool - (define (xexpr-attribute? b) - (and (pair? b) - (symbol? (car b)) - (pair? (cdr b)) - (string? (cadr b)) - (null? (cddr b)))) - - ; permissive? : parameter bool - (define permissive? (make-parameter #f)) - - ;; xml->xexpr : Content -> Xexpr - (define (xml->xexpr x) - (let* ([non-dropping-combine - (lambda (atts body) - (cons (assoc-sort (map attribute->srep atts)) - body))] - [combine (if (xexpr-drop-empty-attributes) - (lambda (atts body) - (if (null? atts) - body - (non-dropping-combine atts body))) - non-dropping-combine)]) - (let loop ([x x]) - (cond - [(element? x) - (let ([body (map loop (element-content x))] - [atts (element-attributes x)]) - (cons (element-name x) (combine atts body)))] - [(pcdata? x) (pcdata-string x)] - [(entity? x) (entity-text x)] - [(or (comment? x) (pi? x) (cdata? x)) x] - [(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)] - [(permissive?) x] - [else (error 'xml->xexpr "Expected content, given ~e" x)])))) - - ;; attribute->srep : Attribute -> Attribute-srep - (define (attribute->srep a) - (list (attribute-name a) (attribute-value a))) - - ;; srep->attribute : Attribute-srep -> Attribute - (define (srep->attribute a) - (unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a))) - (error 'srep->attribute "expected (list Symbol String) given ~e" a)) - (make-attribute 'scheme 'scheme (car a) (cadr a))) - - ;; xexpr->xml : Xexpr -> Content - ;; The contract is enforced. - (define (xexpr->xml x) + (cadr attr)))) + (false (make-exn:invalid-xexpr + (format "Expected a symbol, given ~a" (car attr)) + (current-continuation-marks) + (cadr attr))))) + + ;; ; end xexpr? helpers + ;; ;; ;; ;; ;; ;; ;; ;; + + + ; : (a -> bool) tst -> bool + ; To check if l is a (listof p?) + ; Don't use (and (list? l) (andmap p? l)) because l may be improper. + (define (listof? p? l) + (let listof-p? ([l l]) + (or (null? l) + (and (cons? l) (p? (car l)) (listof-p? (cdr l)))))) + + ; : tst -> bool + (define (xexpr-attribute? b) + (and (pair? b) + (symbol? (car b)) + (pair? (cdr b)) + (string? (cadr b)) + (null? (cddr b)))) + + ; permissive? : parameter bool + (define permissive? (make-parameter #f)) + + ;; xml->xexpr : Content -> Xexpr + (define (xml->xexpr x) + (let* ([non-dropping-combine + (lambda (atts body) + (cons (assoc-sort (map attribute->srep atts)) + body))] + [combine (if (xexpr-drop-empty-attributes) + (lambda (atts body) + (if (null? atts) + body + (non-dropping-combine atts body))) + non-dropping-combine)]) + (let loop ([x x]) (cond - [(pair? x) - (let ([f (lambda (atts body) - (unless (list? body) - (error 'xexpr->xml - "expected a list of xexprs for the body in ~e" - x)) - (make-element 'scheme 'scheme (car x) - atts - (map xexpr->xml body)))]) - (if (and (pair? (cdr x)) - (or (null? (cadr x)) - (and (pair? (cadr x)) (pair? (caadr x))))) - (f (map srep->attribute (cadr x)) (cddr x)) - (f null (cdr x))))] - [(string? x) (make-pcdata 'scheme 'scheme x)] - [(or (symbol? x) (exact-nonnegative-integer? x)) - (make-entity 'scheme 'scheme x)] + [(element? x) + (let ([body (map loop (element-content x))] + [atts (element-attributes x)]) + (cons (element-name x) (combine atts body)))] + [(pcdata? x) (pcdata-string x)] + [(entity? x) (entity-text x)] [(or (comment? x) (pi? x) (cdata? x)) x] - [else ;(error 'xexpr->xml "malformed xexpr ~e" x) - x])) - - ;; xexpr->string : Xexpression -> String - (define (xexpr->string xexpr) - (let ([port (open-output-string)]) - (write-xml/content (xexpr->xml xexpr) port) - (get-output-string port))) - - ;; bcompose : (a a -> c) (b -> a) -> (b b -> c) - (define (bcompose f g) - (lambda (x y) (f (g x) (g y))))))) + [(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)] + [(permissive?) x] + [else (error 'xml->xexpr "Expected content, given ~e" x)])))) + + ;; attribute->srep : Attribute -> Attribute-srep + (define (attribute->srep a) + (list (attribute-name a) (attribute-value a))) + + ;; srep->attribute : Attribute-srep -> Attribute + (define (srep->attribute a) + (unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a))) + (error 'srep->attribute "expected (list Symbol String) given ~e" a)) + (make-attribute 'scheme 'scheme (car a) (cadr a))) + + ;; xexpr->xml : Xexpr -> Content + ;; The contract is enforced. + (define (xexpr->xml x) + (cond + [(pair? x) + (let ([f (lambda (atts body) + (unless (list? body) + (error 'xexpr->xml + "expected a list of xexprs for the body in ~e" + x)) + (make-element 'scheme 'scheme (car x) + atts + (map xexpr->xml body)))]) + (if (and (pair? (cdr x)) + (or (null? (cadr x)) + (and (pair? (cadr x)) (pair? (caadr x))))) + (f (map srep->attribute (cadr x)) (cddr x)) + (f null (cdr x))))] + [(string? x) (make-pcdata 'scheme 'scheme x)] + [(or (symbol? x) (exact-nonnegative-integer? x)) + (make-entity 'scheme 'scheme x)] + [(or (comment? x) (pi? x) (cdata? x) (pcdata? x)) x] + [else ;(error 'xexpr->xml "malformed xexpr ~e" x) + x])) + + ;; xexpr->string : Xexpression -> String + (define (xexpr->string xexpr) + (let ([port (open-output-string)]) + (write-xml/content (xexpr->xml xexpr) port) + (get-output-string port))) + + ;; bcompose : (a a -> c) (b -> a) -> (b b -> c) + (define (bcompose f g) + (lambda (x y) (f (g x) (g y))))) diff --git a/collects/xml/xml-sig.ss b/collects/xml/xml-sig.ss index 8f6bb02f96..1db8fea971 100644 --- a/collects/xml/xml-sig.ss +++ b/collects/xml/xml-sig.ss @@ -1,14 +1,19 @@ +#lang scheme +(require "private/sig.ss") -(module xml-sig mzscheme - (require mzlib/unitsig) - - (require "private/sig.ss") - - (define-signature xml^ - ((open xml-structs^) (open reader^) (open writer^) (open xexpr^) (open space^) - syntax:read-xml syntax:read-xml/element)) - - (provide xml^)) - +(define-signature xml-syntax^ + ((contracted + ; XXX these should both actually return syntax? that is also xexpr/c + [syntax:read-xml (() (input-port?) . ->* . syntax?)] + [syntax:read-xml/element (() (input-port?) . ->* . syntax?)]))) +(define-signature xml^ + ((open xml-structs^) + (open reader^) + (open writer^) + (open xexpr^) + (open space^) + (open xml-syntax^))) +(provide xml^ + xml-syntax^) diff --git a/collects/xml/xml-unit.ss b/collects/xml/xml-unit.ss index d378e2d1cc..2ea7450497 100644 --- a/collects/xml/xml-unit.ss +++ b/collects/xml/xml-unit.ss @@ -1,28 +1,74 @@ +#lang scheme +(require "xml-sig.ss" + "private/sig.ss" + "private/structures.ss" + "private/reader.ss" + "private/writer.ss" + "private/xexpr.ss" + "private/space.ss" + "private/syntax.ss") -(module xml-unit mzscheme - (require mzlib/unitsig) +(provide xml@) - (require "xml-sig.ss" "private/sig.ss" - "private/structures.ss" - "private/reader.ss" - "private/writer.ss" - "private/xexpr.ss" - "private/space.ss" - "private/syntax.ss") +(define-unit reader->xml-syntax@ + (import reader^) + (export xml-syntax^) + (define syntax:read-xml read-xml) + (define syntax:read-xml/element read-xml/element)) - (provide xml@) +(define-compound-unit/infer xml-syntax@ + (import) + (export xml-syntax^) + (link syntax-structs@ reader@ reader->xml-syntax@)) - (define xml@ - (compound-unit/sig - (import) - (link - [S : xml-structs^ (xml-structs@)] - [SS : xml-structs^ (syntax-structs@)] - [R : reader^ (reader@ S)] - [R2 : reader^ (reader@ SS)] - (U : writer^ (writer@ S)) - (T : xexpr^ (xexpr@ S U)) - (W : space^ (space@ S))) - (export (open S) (open R) (var (R2 read-xml) syntax:read-xml) - (var (R2 read-xml/element) syntax:read-xml/element) - (open U) (open T) (open W))))) +(define-unit native-xml-syntax@ + (import xml-structs^ reader^ xexpr^) + (export xml-syntax^) + + (define (syntax:read-xml [in (current-input-port)]) + (define the-xml (read-xml in)) + (define the-xml-element (document-element the-xml)) + (element->xexpr-syntax the-xml-element)) + + (define (syntax:read-xml/element [in (current-input-port)]) + (define the-xml-element (read-xml/element in)) + (element->xexpr-syntax the-xml-element)) + + (define (position from to) + (let ([start-offset (location-offset from)]) + (list #f (location-line from) (location-char from) start-offset + (- (location-offset to) start-offset)))) + + (define (wrap s e) + (datum->syntax #f e (position (source-start s) (source-stop s)))) + + (define (attribute->syntax a) + (wrap a (list (attribute-name a) (attribute-value a)))) + + (define (non-dropping-combine atts body) + (list* (map attribute->syntax atts) body)) + + (define (combine atts body) + (if (xexpr-drop-empty-attributes) + (if (empty? atts) + body + (non-dropping-combine atts body)) + (non-dropping-combine atts body))) + + (define (element->xexpr-syntax e) + (wrap e + (list* (element-name e) + (combine (element-attributes e) + (map content->xexpr-syntax (element-content e)))))) + + (define (content->xexpr-syntax x) + (cond + [(element? x) (element->xexpr-syntax x)] + [(pcdata? x) (wrap x (pcdata-string x))] + [(entity? x) (wrap x (entity-text x))] + [else (wrap x x)]))) + +(define-compound-unit/infer xml@ + (import) + (export xml-structs^ reader^ xml-syntax^ writer^ xexpr^ space^) + (link xml-structs@ reader@ native-xml-syntax@ writer@ xexpr@ space@)) diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index 1b91c065db..155c8d3c9c 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -81,20 +81,7 @@ Represents a document.} [dtd (or/c document-type false/c)] [misc2 (listof (or/c comment? p-i?))])]{ -Represents a document prolog. The @scheme[make-prolog] binding is -unusual: it accepts two or more arguments, and all arguments after the -first two are collected into the @scheme[misc2] field. - -@examples[ -#:eval xml-eval -(make-prolog empty #f) -(make-prolog empty #f (make-p-i #f #f "k1" "v1")) -(make-prolog empty #f (make-p-i #f #f "k1" "v1") - (make-p-i #f #f "k2" "v2")) -@(code:comment "This example breaks the contract by providing") -@(code:comment "a list rather than a comment or p-i") -(prolog-misc2 (make-prolog empty #f empty)) -] +Represents a document prolog. } @defstruct[document-type ([name symbol?] @@ -273,7 +260,7 @@ Converts an @tech{X-expression} into XML content.} Converts an @tech{X-expression} into a string containing XML.} @defproc[((eliminate-whitespace [tags (listof symbol?)] - [choose (boolean? . -> . any/c)]) + [choose (boolean? . -> . boolean?)]) [elem element?]) element?]{ @@ -284,7 +271,7 @@ tag names as @scheme[tag]s and the identity function as that filters out PCDATA consisting solely of whitespace from those elements, and it raises an error if any non-whitespace text appears. Passing in @scheme[not] as @scheme[choose] filters all elements which -are not named in the @scheme[tags] list. Using @scheme[void] as +are not named in the @scheme[tags] list. Using @scheme[(lambda (x) #t)] as @scheme[choose] filters all elements regardless of the @scheme[tags] list.} diff --git a/collects/xml/xml.ss b/collects/xml/xml.ss index 5fb75ccfd0..f4103edb9d 100644 --- a/collects/xml/xml.ss +++ b/collects/xml/xml.ss @@ -1,10 +1,7 @@ +#lang scheme +(require "xml-sig.ss" + "xml-unit.ss") -(module xml mzscheme - (require mzlib/unitsig) +(define-values/invoke-unit/infer xml@) - (require "xml-sig.ss" - "xml-unit.ss") - - (define-values/invoke-unit/sig xml^ xml@) - - (provide-signature-elements xml^)) +(provide-signature-elements xml^) \ No newline at end of file From 243fb2f0e432d5c463261bb78818ef8d62f070fc Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 26 Feb 2009 17:15:44 +0000 Subject: [PATCH 137/142] indent svn: r13855 --- collects/html/html-mod.ss | 248 +++++------ collects/html/sgml-reader.ss | 776 +++++++++++++++++------------------ 2 files changed, 512 insertions(+), 512 deletions(-) diff --git a/collects/html/html-mod.ss b/collects/html/html-mod.ss index 49a6f71b9e..5356f9949d 100644 --- a/collects/html/html-mod.ss +++ b/collects/html/html-mod.ss @@ -8,130 +8,130 @@ "html-spec.ss" "html-sig.ss" (prefix-in sgml: "sgml-reader.ss") - xml) + xml) (provide-signature-elements html^) - - ;; Html-content = Html-element | Pc-data | Entity - - (include "html-structs.ss") - (include "case.ss") - - ;; xml->html : Document -> Html - (define (xml->html doc) - (let ([root (document-element doc)]) - (unless (eq? 'html (element-name root)) - (error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root))) - (make-html (element-attributes root) (xml-contents->html (element-content root))))) - - - ;; xml-content->html : (listof Content) -> (listof Html-element) - (define (xml-contents->html contents) - (foldr xml-single-content->html - null - contents)) - - ;; read-xhtml : [Input-port] -> Html - (define read-xhtml (compose xml->html read-xml)) - - ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content) - (define (peel-f toss? to-toss acc0) - (foldr (lambda (x acc) - (if (toss? x) - (append (html-full-content x) acc) - (cons x acc))) - acc0 - to-toss)) - - ;; repackage-html : (listof Html-content) -> Html - (define (repackage-html contents) - (let* ([html (memf html? contents)] - [peeled (peel-f html? contents null)] - [body (memf body? peeled)]) - (make-html (if html - (html-element-attributes (car html)) - null) - (append (filter head? peeled) - (list (make-body (if body - (html-element-attributes (car body)) - null) - (filter (compose not head?) (peel-f body? peeled null)))))))) - + +;; Html-content = Html-element | Pc-data | Entity + +(include "html-structs.ss") +(include "case.ss") + +;; xml->html : Document -> Html +(define (xml->html doc) + (let ([root (document-element doc)]) + (unless (eq? 'html (element-name root)) + (error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root))) + (make-html (element-attributes root) (xml-contents->html (element-content root))))) + + +;; xml-content->html : (listof Content) -> (listof Html-element) +(define (xml-contents->html contents) + (foldr xml-single-content->html + null + contents)) + +;; read-xhtml : [Input-port] -> Html +(define read-xhtml (compose xml->html read-xml)) + +;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content) +(define (peel-f toss? to-toss acc0) + (foldr (lambda (x acc) + (if (toss? x) + (append (html-full-content x) acc) + (cons x acc))) + acc0 + to-toss)) + +;; repackage-html : (listof Html-content) -> Html +(define (repackage-html contents) + (let* ([html (memf html? contents)] + [peeled (peel-f html? contents null)] + [body (memf body? peeled)]) + (make-html (if html + (html-element-attributes (car html)) + null) + (append (filter head? peeled) + (list (make-body (if body + (html-element-attributes (car body)) + null) + (filter (compose not head?) (peel-f body? peeled null)))))))) + +;; clean-up-pcdata : (listof Content) -> (listof Content) +;; Each pcdata inside a tag that isn't supposed to contain pcdata is either +;; a) appended to the end of the previous subelement, if that subelement may contain pcdata +;; b) prepended to the front of the next subelement, if that subelement may contain pcdata +;; c) discarded +;; unknown tags may contain pcdata +;; the top level may contain pcdata +(define clean-up-pcdata ;; clean-up-pcdata : (listof Content) -> (listof Content) - ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either - ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata - ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata - ;; c) discarded - ;; unknown tags may contain pcdata - ;; the top level may contain pcdata - (define clean-up-pcdata - ;; clean-up-pcdata : (listof Content) -> (listof Content) - (letrec ([clean-up-pcdata - (lambda (content) - (map (lambda (to-fix) - (cond - [(element? to-fix) - (recontent-xml to-fix - (let ([possible (may-contain (element-name to-fix))] - [content (element-content to-fix)]) - (if (or (not possible) (memq 'pcdata possible)) - (clean-up-pcdata content) - (eliminate-pcdata content))))] - [else to-fix])) - content))] - [eliminate-pcdata - ;: (listof Content) -> (listof Content) - (lambda (content) - (let ([non-elements (first-non-elements content)] - [more (memf element? content)]) - (if more - (let* ([el (car more)] - [possible (may-contain (element-name el))]) - (if (or (not possible) (memq 'pcdata possible)) - (cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more))))) - (or (memf element? (cdr more)) null)) - (cons (recontent-xml el (eliminate-pcdata (element-content el))) - (eliminate-pcdata (cdr more))))) - null)))]) - clean-up-pcdata)) - - ;; first-non-elements : (listof Content) -> (listof Content) - (define (first-non-elements content) - (cond - [(null? content) null] - [else (if (element? (car content)) - null - (cons (car content) (first-non-elements (cdr content))))])) - - ;; recontent-xml : Element (listof Content) -> Element - (define (recontent-xml e c) - (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c)) - - ;; implicit-starts : Symbol Symbol -> (U #f Symbol) - (define (implicit-starts parent child) - (or (and (eq? child 'tr) (eq? parent 'table) 'tbody) - (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr))) - - ;; may-contain : Kid-lister - (define may-contain - (sgml:gen-may-contain html-spec)) - - (define may-contain-anything - (sgml:gen-may-contain null)) - - (define use-html-spec (make-parameter #t)) - - ;; read-html-as-xml : [Input-port] -> (listof Content) - (define read-html-as-xml - (case-lambda - [(port) - ((if (use-html-spec) clean-up-pcdata values) - ((sgml:gen-read-sgml (if (use-html-spec) - may-contain - may-contain-anything) - implicit-starts) port))] - [() (read-html-as-xml (current-input-port))])) - - ;; read-html : [Input-port] -> Html - (define read-html - (compose repackage-html xml-contents->html read-html-as-xml)) \ No newline at end of file + (letrec ([clean-up-pcdata + (lambda (content) + (map (lambda (to-fix) + (cond + [(element? to-fix) + (recontent-xml to-fix + (let ([possible (may-contain (element-name to-fix))] + [content (element-content to-fix)]) + (if (or (not possible) (memq 'pcdata possible)) + (clean-up-pcdata content) + (eliminate-pcdata content))))] + [else to-fix])) + content))] + [eliminate-pcdata + ;: (listof Content) -> (listof Content) + (lambda (content) + (let ([non-elements (first-non-elements content)] + [more (memf element? content)]) + (if more + (let* ([el (car more)] + [possible (may-contain (element-name el))]) + (if (or (not possible) (memq 'pcdata possible)) + (cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more))))) + (or (memf element? (cdr more)) null)) + (cons (recontent-xml el (eliminate-pcdata (element-content el))) + (eliminate-pcdata (cdr more))))) + null)))]) + clean-up-pcdata)) + +;; first-non-elements : (listof Content) -> (listof Content) +(define (first-non-elements content) + (cond + [(null? content) null] + [else (if (element? (car content)) + null + (cons (car content) (first-non-elements (cdr content))))])) + +;; recontent-xml : Element (listof Content) -> Element +(define (recontent-xml e c) + (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c)) + +;; implicit-starts : Symbol Symbol -> (U #f Symbol) +(define (implicit-starts parent child) + (or (and (eq? child 'tr) (eq? parent 'table) 'tbody) + (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr))) + +;; may-contain : Kid-lister +(define may-contain + (sgml:gen-may-contain html-spec)) + +(define may-contain-anything + (sgml:gen-may-contain null)) + +(define use-html-spec (make-parameter #t)) + +;; read-html-as-xml : [Input-port] -> (listof Content) +(define read-html-as-xml + (case-lambda + [(port) + ((if (use-html-spec) clean-up-pcdata values) + ((sgml:gen-read-sgml (if (use-html-spec) + may-contain + may-contain-anything) + implicit-starts) port))] + [() (read-html-as-xml (current-input-port))])) + +;; read-html : [Input-port] -> Html +(define read-html + (compose repackage-html xml-contents->html read-html-as-xml)) \ No newline at end of file diff --git a/collects/html/sgml-reader.ss b/collects/html/sgml-reader.ss index 4dfe8a95be..6de4bbb93b 100644 --- a/collects/html/sgml-reader.ss +++ b/collects/html/sgml-reader.ss @@ -5,286 +5,286 @@ (require mzlib/list mzlib/string "sgml-reader-sig.ss" - xml) + xml) (provide-signature-elements sgml-reader^) - ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) - (define-struct (start-tag source) (name attrs)) - - ;; End-tag ::= (make-end-tag Location Location Symbol) - (define-struct (end-tag source) (name)) - - ;; Token ::= Contents | Start-tag | End-tag | Eof - - (define read-html-comments (make-parameter #f)) - (define trim-whitespace (make-parameter #f)) - - ;; Kid-lister : (Symbol -> (U (listof Symbol) #f)) - - ;; gen-may-contain : Spec -> Kid-lister - (define (gen-may-contain spec) - (let ([table (make-hash)]) - (for-each (lambda (def) - (let ([rhs (cdr def)]) - (for-each (lambda (name) (hash-set! table name rhs)) - (car def)))) - spec) - (lambda (name) - (hash-ref table name (lambda () #f))))) - - ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content) - (define (gen-read-sgml may-contain auto-insert) - (case-lambda - [(in) (read-from-port may-contain auto-insert in)] - [() (read-from-port may-contain auto-insert (current-input-port))])) - - ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content) - (define (read-from-port may-contain auto-insert in) - (let loop ([tokens (let read-tokens () - (let ([tok (lex in)]) - (cond - [(eof-object? tok) null] - [else (cons tok (read-tokens))])))]) - (cond - [(null? tokens) null] - [else - (let ([tok (car tokens)] [rest-tokens (cdr tokens)]) - (cond - [(start-tag? tok) - (let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)]) - (cons el (loop more-tokens)))] - [(end-tag? tok) (loop rest-tokens)] - [else (let ([rest-contents (loop rest-tokens)]) - (expand-content tok rest-contents))]))]))) - - ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token) - ;; Note: How elements nest depends on their content model. - ;; If a kind of element can't contain anything, then its start tags are implicitly ended, and - ;; end tags are implicitly started. - ;; Unknown elements can contain anything and can go inside anything. - ;; Otherwise, only the subelements listed in the content model can go inside an element. - ;; more here - may-contain shouldn't be used to decide if an element is known or not. - ;; The edgar dtd puts tags in may-contain's range that aren't in its domain. - ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the - ;; tag nesting depth. However, this only should be a problem when the tag is there, - ;; but far back. That shouldn't happen often. I'm guessing n will be about 3. - (define (read-element start-tag context may-contain auto-insert tokens) - (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens]) - (let* ([start-name (start-tag-name start-tag)] - [ok-kids (may-contain start-name)]) - (let-values ([(content remaining) - (cond - [(null? ok-kids) (values null tokens)] - [else - ;; read-content : (listof Token) -> (listof Content) (listof Token) - (let read-content ([tokens tokens]) - (cond - [(null? tokens) (values null tokens)] - [else - (let ([tok (car tokens)] [next-tokens (cdr tokens)]) - (cond - [(start-tag? tok) - (let* ([name (start-tag-name tok)] - [auto-start (auto-insert start-name name)]) - (if auto-start - (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens)) - (if (and ok-kids - (not (memq name ok-kids)) - (may-contain name)) - (values null tokens) - (let*-values ([(element post-element) - (read-el tok (cons name context) next-tokens)] - [(more-contents left-overs) (read-content post-element)]) - (values (cons element more-contents) left-overs)))))] - [(end-tag? tok) - (let ([name (end-tag-name tok)]) - (if (eq? name start-name) - (values null next-tokens) - (if (memq name context) - (values null tokens) - (read-content next-tokens))))] - [else ;; content - (let-values ([(more-contents left-overs) (read-content next-tokens)]) - (values - (expand-content tok more-contents) - left-overs))]))]))])]) - (values (make-element (source-start start-tag) - (source-stop start-tag) - start-name - (start-tag-attrs start-tag) - content) - remaining))))) - - ;; expand-content : Content (listof Content) -> (listof Content) - (define (expand-content x lst) +;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) +(define-struct (start-tag source) (name attrs)) + +;; End-tag ::= (make-end-tag Location Location Symbol) +(define-struct (end-tag source) (name)) + +;; Token ::= Contents | Start-tag | End-tag | Eof + +(define read-html-comments (make-parameter #f)) +(define trim-whitespace (make-parameter #f)) + +;; Kid-lister : (Symbol -> (U (listof Symbol) #f)) + +;; gen-may-contain : Spec -> Kid-lister +(define (gen-may-contain spec) + (let ([table (make-hash)]) + (for-each (lambda (def) + (let ([rhs (cdr def)]) + (for-each (lambda (name) (hash-set! table name rhs)) + (car def)))) + spec) + (lambda (name) + (hash-ref table name (lambda () #f))))) + +;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content) +(define (gen-read-sgml may-contain auto-insert) + (case-lambda + [(in) (read-from-port may-contain auto-insert in)] + [() (read-from-port may-contain auto-insert (current-input-port))])) + +;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content) +(define (read-from-port may-contain auto-insert in) + (let loop ([tokens (let read-tokens () + (let ([tok (lex in)]) + (cond + [(eof-object? tok) null] + [else (cons tok (read-tokens))])))]) (cond - [(entity? x) (cons (expand-entity x) lst)] - [(comment? x) (if (read-html-comments) - (cons x lst) - lst)] - [else (cons x lst)])) - - ;; expand-entity : Entity -> (U Entity Pcdata) - ;; more here - allow expansion of user defined entities - (define (expand-entity x) - (let ([expanded (default-entity-table (entity-text x))]) - (if expanded - (make-pcdata (source-start x) (source-stop x) expanded) - x))) - - ;; default-entity-table : Symbol -> (U #f String) - (define (default-entity-table name) - (case name - [(amp) "&"] - [(lt) "<"] - [(gt) ">"] - [(quot) "\""] - [(apos) "'"] - [else #f])) - - ;; lex : Input-port -> Token - (define (lex in) - (when (trim-whitespace) - (skip-space in)) - (let ([c (peek-char in)]) - (cond - [(eof-object? c) c] - [(eq? c #\&) (lex-entity in)] - [(eq? c #\<) (lex-tag-cdata-pi-comment in)] - [else (lex-pcdata in)]))) - - ;; lex-entity : Input-port -> Token - ;; This might not return an entity if it doesn't look like one afterall. - (define (lex-entity in) - (let ([start (file-position in)]) - (read-char in) - (case (peek-char in) - ;; more here - read while it's numeric (or hex) not until #\; - [(#\#) - (read-char in) - (let* ([hex? (if (equal? #\x (peek-char in)) - (and (read-char in) #t) - #f)] - [str (read-until #\; in)] - [n (cond - [hex? - (string->number str 16)] - [else (string->number str)])]) - (if (number? n) - (make-entity start (file-position in) n) - (make-pcdata start (file-position in) (string-append "&#" str))))] - [else - (let ([name (lex-name/case-sensitive in)] - [c (peek-char in)]) - (if (eq? c #\;) - (begin (read-char in) (make-entity start (file-position in) name)) - (make-pcdata start (file-position in) (format "&~a" name))))]))) - - ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment - (define (lex-tag-cdata-pi-comment in) - (let ([start (file-position in)]) - (read-char in) - (case (peek-char in) - [(#\!) - (read-char in) - (case (peek-char in) - [(#\-) (read-char in) - (let ([c (read-char in)]) + [(null? tokens) null] + [else + (let ([tok (car tokens)] [rest-tokens (cdr tokens)]) + (cond + [(start-tag? tok) + (let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)]) + (cons el (loop more-tokens)))] + [(end-tag? tok) (loop rest-tokens)] + [else (let ([rest-contents (loop rest-tokens)]) + (expand-content tok rest-contents))]))]))) + +;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token) +;; Note: How elements nest depends on their content model. +;; If a kind of element can't contain anything, then its start tags are implicitly ended, and +;; end tags are implicitly started. +;; Unknown elements can contain anything and can go inside anything. +;; Otherwise, only the subelements listed in the content model can go inside an element. +;; more here - may-contain shouldn't be used to decide if an element is known or not. +;; The edgar dtd puts tags in may-contain's range that aren't in its domain. +;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the +;; tag nesting depth. However, this only should be a problem when the tag is there, +;; but far back. That shouldn't happen often. I'm guessing n will be about 3. +(define (read-element start-tag context may-contain auto-insert tokens) + (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens]) + (let* ([start-name (start-tag-name start-tag)] + [ok-kids (may-contain start-name)]) + (let-values ([(content remaining) (cond - [(eq? c #\-) - (let ([data (lex-comment-contents in)]) - (make-comment data))] - [else (make-pcdata start (file-position in) (format " or whatever else is there - (make-end-tag start (file-position in) name))] - [else - (let ([name (lex-name in)] - [attrs (lex-attributes in)]) - (skip-space in) - (case (read-char in) - [(#\/) - (read-char in) ;; skip #\> or something - (make-element start (file-position in) name attrs null)] - [else (make-start-tag start (file-position in) name attrs)]))]))) - - - ;; lex-attributes : Input-port -> (listof Attribute) - (define (lex-attributes in) - (sort (let loop () - (skip-space in) - (cond [(name-start? (peek-char in)) - (cons (lex-attribute in) (loop))] - [else null])) - (lambda (a b) - (stringstring (attribute-name a)) - (symbol->string (attribute-name b)))))) - - ;; lex-attribute : Input-port -> Attribute - ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax - (define (lex-attribute in) - (let ([start (file-position in)] - [name (lex-name in)]) - (skip-space in) - (cond - [(eq? (peek-char in) #\=) - (read-char in) + [(null? ok-kids) (values null tokens)] + [else + ;; read-content : (listof Token) -> (listof Content) (listof Token) + (let read-content ([tokens tokens]) + (cond + [(null? tokens) (values null tokens)] + [else + (let ([tok (car tokens)] [next-tokens (cdr tokens)]) + (cond + [(start-tag? tok) + (let* ([name (start-tag-name tok)] + [auto-start (auto-insert start-name name)]) + (if auto-start + (read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens)) + (if (and ok-kids + (not (memq name ok-kids)) + (may-contain name)) + (values null tokens) + (let*-values ([(element post-element) + (read-el tok (cons name context) next-tokens)] + [(more-contents left-overs) (read-content post-element)]) + (values (cons element more-contents) left-overs)))))] + [(end-tag? tok) + (let ([name (end-tag-name tok)]) + (if (eq? name start-name) + (values null next-tokens) + (if (memq name context) + (values null tokens) + (read-content next-tokens))))] + [else ;; content + (let-values ([(more-contents left-overs) (read-content next-tokens)]) + (values + (expand-content tok more-contents) + left-overs))]))]))])]) + (values (make-element (source-start start-tag) + (source-stop start-tag) + start-name + (start-tag-attrs start-tag) + content) + remaining))))) + +;; expand-content : Content (listof Content) -> (listof Content) +(define (expand-content x lst) + (cond + [(entity? x) (cons (expand-entity x) lst)] + [(comment? x) (if (read-html-comments) + (cons x lst) + lst)] + [else (cons x lst)])) + +;; expand-entity : Entity -> (U Entity Pcdata) +;; more here - allow expansion of user defined entities +(define (expand-entity x) + (let ([expanded (default-entity-table (entity-text x))]) + (if expanded + (make-pcdata (source-start x) (source-stop x) expanded) + x))) + +;; default-entity-table : Symbol -> (U #f String) +(define (default-entity-table name) + (case name + [(amp) "&"] + [(lt) "<"] + [(gt) ">"] + [(quot) "\""] + [(apos) "'"] + [else #f])) + +;; lex : Input-port -> Token +(define (lex in) + (when (trim-whitespace) + (skip-space in)) + (let ([c (peek-char in)]) + (cond + [(eof-object? c) c] + [(eq? c #\&) (lex-entity in)] + [(eq? c #\<) (lex-tag-cdata-pi-comment in)] + [else (lex-pcdata in)]))) + +;; lex-entity : Input-port -> Token +;; This might not return an entity if it doesn't look like one afterall. +(define (lex-entity in) + (let ([start (file-position in)]) + (read-char in) + (case (peek-char in) + ;; more here - read while it's numeric (or hex) not until #\; + [(#\#) + (read-char in) + (let* ([hex? (if (equal? #\x (peek-char in)) + (and (read-char in) #t) + #f)] + [str (read-until #\; in)] + [n (cond + [hex? + (string->number str 16)] + [else (string->number str)])]) + (if (number? n) + (make-entity start (file-position in) n) + (make-pcdata start (file-position in) (string-append "&#" str))))] + [else + (let ([name (lex-name/case-sensitive in)] + [c (peek-char in)]) + (if (eq? c #\;) + (begin (read-char in) (make-entity start (file-position in) name)) + (make-pcdata start (file-position in) (format "&~a" name))))]))) + +;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment +(define (lex-tag-cdata-pi-comment in) + (let ([start (file-position in)]) + (read-char in) + (case (peek-char in) + [(#\!) + (read-char in) + (case (peek-char in) + [(#\-) (read-char in) + (let ([c (read-char in)]) + (cond + [(eq? c #\-) + (let ([data (lex-comment-contents in)]) + (make-comment data))] + [else (make-pcdata start (file-position in) (format " or whatever else is there + (make-end-tag start (file-position in) name))] + [else + (let ([name (lex-name in)] + [attrs (lex-attributes in)]) (skip-space in) - (let* ([delimiter (read-char in)] - [value (list->string - (case delimiter - [(#\' #\") - (let read-more () - (let ([c (read-char in)]) - (cond - [(or (eq? c delimiter) (eof-object? c)) null] - [else (cons c (read-more))])))] - [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))]) - (make-attribute start (file-position in) name value))] - [else (make-attribute start (file-position in) name (symbol->string name))]))) - - ;; skip-space : Input-port -> Void - ;; deviation - should sometimes insist on at least one space - (define (skip-space in) - (let loop () - (let ([c (peek-char in)]) - (when (and (not (eof-object? c)) (char-whitespace? c)) - (read-char in) - (loop))))) - - ;; lex-pcdata : Input-port -> Pcdata - ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec - (define (lex-pcdata in) - (let ([start (file-position in)]) - ;; The following regexp match must use bytes, not chars, because - ;; `in' might not be a well-formed UTF-8 sequence. If it isn't, - ;; and it goes wrong with the first byte sequence, then a char-based - ;; pattern would match 0 characters. Meanwhile, the caller of this function - ;; expects characters to be read. - (let ([s (regexp-match #rx#"^[^&<]*" in)]) - (make-pcdata start - (file-position in) - (bytes->string/utf-8 - (if (trim-whitespace) - (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"") - (car s)) - #\?))))) - #| + (case (read-char in) + [(#\/) + (read-char in) ;; skip #\> or something + (make-element start (file-position in) name attrs null)] + [else (make-start-tag start (file-position in) name attrs)]))]))) + + +;; lex-attributes : Input-port -> (listof Attribute) +(define (lex-attributes in) + (sort (let loop () + (skip-space in) + (cond [(name-start? (peek-char in)) + (cons (lex-attribute in) (loop))] + [else null])) + (lambda (a b) + (stringstring (attribute-name a)) + (symbol->string (attribute-name b)))))) + +;; lex-attribute : Input-port -> Attribute +;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax +(define (lex-attribute in) + (let ([start (file-position in)] + [name (lex-name in)]) + (skip-space in) + (cond + [(eq? (peek-char in) #\=) + (read-char in) + (skip-space in) + (let* ([delimiter (read-char in)] + [value (list->string + (case delimiter + [(#\' #\") + (let read-more () + (let ([c (read-char in)]) + (cond + [(or (eq? c delimiter) (eof-object? c)) null] + [else (cons c (read-more))])))] + [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))]) + (make-attribute start (file-position in) name value))] + [else (make-attribute start (file-position in) name (symbol->string name))]))) + +;; skip-space : Input-port -> Void +;; deviation - should sometimes insist on at least one space +(define (skip-space in) + (let loop () + (let ([c (peek-char in)]) + (when (and (not (eof-object? c)) (char-whitespace? c)) + (read-char in) + (loop))))) + +;; lex-pcdata : Input-port -> Pcdata +;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec +(define (lex-pcdata in) + (let ([start (file-position in)]) + ;; The following regexp match must use bytes, not chars, because + ;; `in' might not be a well-formed UTF-8 sequence. If it isn't, + ;; and it goes wrong with the first byte sequence, then a char-based + ;; pattern would match 0 characters. Meanwhile, the caller of this function + ;; expects characters to be read. + (let ([s (regexp-match #rx#"^[^&<]*" in)]) + (make-pcdata start + (file-position in) + (bytes->string/utf-8 + (if (trim-whitespace) + (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"") + (car s)) + #\?))))) +#| ;; Original slow version: (define (lex-pcdata in) (let ([start (file-position in)] @@ -304,23 +304,23 @@ (file-position in) (list->string data)))) |# - - - ;; lex-name : Input-port -> Symbol - (define (lex-name in) - (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) - (string->symbol - ;; Common case: string is already lowercased - (if (regexp-match-positions #rx"[A-Z]" s) - (begin - (string-lowercase! s) - s) - s)))) - ;; lex-name/case-sensitive : Input-port -> Symbol - (define (lex-name/case-sensitive in) - (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) - (string->symbol s))) - #| + + +;; lex-name : Input-port -> Symbol +(define (lex-name in) + (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) + (string->symbol + ;; Common case: string is already lowercased + (if (regexp-match-positions #rx"[A-Z]" s) + (begin + (string-lowercase! s) + s) + s)))) +;; lex-name/case-sensitive : Input-port -> Symbol +(define (lex-name/case-sensitive in) + (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) + (string->symbol s))) +#| (define (lex-name in) (string->symbol (list->string @@ -330,100 +330,100 @@ (cons (char-downcase (read-char in)) (lex-rest))] [else null]))))) |# - - - ;; skip-dtd : Input-port -> Void - (define (skip-dtd in) - (let skip () - (let ([c (read-char in)]) - (if (eof-object? c) - (void) - (case c - [(#\') (read-until #\' in) (skip)] - [(#\") (read-until #\" in) (skip)] - [(#\<) - (case (read-char in) - [(#\!) (case (read-char in) - [(#\-) (read-char in) (lex-comment-contents in) (skip)] - [else (skip) (skip)])] - [(#\?) (lex-pi-data in) (skip)] - [else (skip) (skip)])] - [(#\>) (void)] - [else (skip)]))))) - - ;; name-start? : TST -> Bool - (define (name-start? ch) - (and (char? ch) (char-name-start? ch))) - - ;; char-name-start? : Char -> Bool - (define (char-name-start? ch) - (or (char-alphabetic? ch) - (eq? ch #\_) - (eq? ch #\:))) - - ;; name-char? : TST -> Bool - (define (name-char? ch) - (and (char? ch) - (or (char-name-start? ch) - (char-numeric? ch) - (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database - (eq? ch #\.) - (eq? ch #\-)))) - - ;; read-up-to : (Char -> Bool) Input-port -> (listof Char) - ;; abstract this with read-until - (define (read-up-to p? in) - (let loop () - (let ([c (peek-char in)]) - (cond - [(or (eof-object? c) (p? c)) null] - [else (cons (read-char in) (loop))])))) - - ;; read-until : Char Input-port -> String - ;; discards the stop character, too - (define (read-until char in) - (list->string - (let read-more () - (let ([c (read-char in)]) - (cond - [(or (eof-object? c) (eq? c char)) null] - [else (cons c (read-more))]))))) - - ;; gen-read-until-string : String -> Input-port -> String - ;; uses Knuth-Morris-Pratt from - ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 - ;; discards stop from input - (define (gen-read-until-string stop) - (let* ([len (string-length stop)] - [prefix (make-vector len 0)] - [fall-back - (lambda (k c) - (let ([k (let loop ([k k]) - (cond - [(and (> k 0) (not (eq? (string-ref stop k) c))) - (loop (vector-ref prefix (sub1 k)))] - [else k]))]) - (if (eq? (string-ref stop k) c) - (add1 k) - k)))]) - (let init ([k 0] [q 1]) - (when (< q len) - (let ([k (fall-back k (string-ref stop q))]) - (vector-set! prefix q k) - (init k (add1 q))))) - ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop - (lambda (in) - (list->string - (let/ec out - (let loop ([matched 0] [out out]) - (let* ([c (read-char in)] - [matched (fall-back matched c)]) - (cond - [(or (eof-object? c) (= matched len)) (out null)] - [(zero? matched) (cons c (let/ec out (loop matched out)))] - [else (cons c (loop matched out))])))))))) - - ;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore. - (define lex-comment-contents (gen-read-until-string "-->")) - (define lex-pi-data (gen-read-until-string "?>")) - (define lex-cdata-contents (gen-read-until-string "]]>")) + + +;; skip-dtd : Input-port -> Void +(define (skip-dtd in) + (let skip () + (let ([c (read-char in)]) + (if (eof-object? c) + (void) + (case c + [(#\') (read-until #\' in) (skip)] + [(#\") (read-until #\" in) (skip)] + [(#\<) + (case (read-char in) + [(#\!) (case (read-char in) + [(#\-) (read-char in) (lex-comment-contents in) (skip)] + [else (skip) (skip)])] + [(#\?) (lex-pi-data in) (skip)] + [else (skip) (skip)])] + [(#\>) (void)] + [else (skip)]))))) + +;; name-start? : TST -> Bool +(define (name-start? ch) + (and (char? ch) (char-name-start? ch))) + +;; char-name-start? : Char -> Bool +(define (char-name-start? ch) + (or (char-alphabetic? ch) + (eq? ch #\_) + (eq? ch #\:))) + +;; name-char? : TST -> Bool +(define (name-char? ch) + (and (char? ch) + (or (char-name-start? ch) + (char-numeric? ch) + (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database + (eq? ch #\.) + (eq? ch #\-)))) + +;; read-up-to : (Char -> Bool) Input-port -> (listof Char) +;; abstract this with read-until +(define (read-up-to p? in) + (let loop () + (let ([c (peek-char in)]) + (cond + [(or (eof-object? c) (p? c)) null] + [else (cons (read-char in) (loop))])))) + +;; read-until : Char Input-port -> String +;; discards the stop character, too +(define (read-until char in) + (list->string + (let read-more () + (let ([c (read-char in)]) + (cond + [(or (eof-object? c) (eq? c char)) null] + [else (cons c (read-more))]))))) + +;; gen-read-until-string : String -> Input-port -> String +;; uses Knuth-Morris-Pratt from +;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 +;; discards stop from input +(define (gen-read-until-string stop) + (let* ([len (string-length stop)] + [prefix (make-vector len 0)] + [fall-back + (lambda (k c) + (let ([k (let loop ([k k]) + (cond + [(and (> k 0) (not (eq? (string-ref stop k) c))) + (loop (vector-ref prefix (sub1 k)))] + [else k]))]) + (if (eq? (string-ref stop k) c) + (add1 k) + k)))]) + (let init ([k 0] [q 1]) + (when (< q len) + (let ([k (fall-back k (string-ref stop q))]) + (vector-set! prefix q k) + (init k (add1 q))))) + ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop + (lambda (in) + (list->string + (let/ec out + (let loop ([matched 0] [out out]) + (let* ([c (read-char in)] + [matched (fall-back matched c)]) + (cond + [(or (eof-object? c) (= matched len)) (out null)] + [(zero? matched) (cons c (let/ec out (loop matched out)))] + [else (cons c (loop matched out))])))))))) + +;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore. +(define lex-comment-contents (gen-read-until-string "-->")) +(define lex-pi-data (gen-read-until-string "?>")) +(define lex-cdata-contents (gen-read-until-string "]]>")) From 9f465fb91764558495d7019af21eac846eb11b01 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 26 Feb 2009 21:08:05 +0000 Subject: [PATCH 138/142] first cut docs for literate programming svn: r13856 --- collects/scribblings/scribble/lp-ex.ss | 16 ++++++ collects/scribblings/scribble/lp.scrbl | 60 ++++++++++++++++++++ collects/scribblings/scribble/scribble.scrbl | 1 + 3 files changed, 77 insertions(+) create mode 100644 collects/scribblings/scribble/lp-ex.ss create mode 100644 collects/scribblings/scribble/lp.scrbl diff --git a/collects/scribblings/scribble/lp-ex.ss b/collects/scribblings/scribble/lp-ex.ss new file mode 100644 index 0000000000..3fc74b37b2 --- /dev/null +++ b/collects/scribblings/scribble/lp-ex.ss @@ -0,0 +1,16 @@ +#lang scribble/lp +Literate programs have chunks of code, like this one: + +@chunk[ + (define (f x) + )] + +and this one: + +@chunk[ + (* x x)] + +that, when assembled, produce a complete program, in this case: + +@schemeblock[(define (f x) + (* x x))] diff --git a/collects/scribblings/scribble/lp.scrbl b/collects/scribblings/scribble/lp.scrbl new file mode 100644 index 0000000000..83f1d6da19 --- /dev/null +++ b/collects/scribblings/scribble/lp.scrbl @@ -0,0 +1,60 @@ +#lang scribble/doc +@(require scribble/manual scheme/runtime-path scribble/lp-include) + +@title[#:tag "lp"]{Literate Programming} + +Programs written using @schememodname[scribble/lp] are simultaneously +two things: a program, and a document describing the program. + +Programs in @schememodname[scribble/lp] are viewed in two different +ways, either by running the program directly, or by including it with +@scheme[include-lp]. When running the program, all of the +@scheme[chunk] expressions are collected and stitched together into a +program and the rest of the module is discarded. When using +@scheme[include-lp], the entire contents of the module are preserved +and are treated like an ordinary Scribble document, where +@scheme[chunk]s are typeset in a manner similar to @scheme[codeblock]. + +@(define-runtime-path lp-ex "lp-ex.ss") + +For example, consider this program: +@(call-with-input-file lp-ex + (lambda (port) + (verbatim + (apply + string-append + (let loop () + (let ([line (read-line port 'any)]) + (cond + [(eof-object? line) '()] + [(equal? line "") (cons " \n" (loop))] + [else + (list* line "\n" (loop))]))))))) + +When this file is @scheme[require]d in the normal manner, it defines a +function @scheme[f] that squares its argument, and the documentation +is ignored. When it is included with @scheme[lp-include], it looks +like this: + +@lp-include["lp-ex.ss"] + +@section{@schememodname[scribble/lp] language} + +@defmodulelang[scribble/lp]{This is a Scribble's core support for Literate Programming.} + +@defform[(chunk expressions ...)]{ + Introduces a chunk, binding @scheme[] for use in other chunks. + + If @scheme[] is @tt{<*>}, then this chunk is used as the main + chunk in the file. If @tt{<*>} is never used, then the first chunk + in the file is treated as the main chunk. +} + +@section{@schememodname[scribble/lp-include] module} + +@defmodule[scribble/lp-include]{} + +@defform[(lp-include filename)]{ +Includes the source of @scheme[filename] as the typeset version of the literate +program. +} \ No newline at end of file diff --git a/collects/scribblings/scribble/scribble.scrbl b/collects/scribblings/scribble/scribble.scrbl index 628e49110b..71fff8e89a 100644 --- a/collects/scribblings/scribble/scribble.scrbl +++ b/collects/scribblings/scribble/scribble.scrbl @@ -37,6 +37,7 @@ starting with the @filepath{scribble.scrbl} file. @include-section["eval.scrbl"] @include-section["srcdoc.scrbl"] @include-section["bnf.scrbl"] +@include-section["lp.scrbl"] @include-section["xref.scrbl"] @include-section["preprocessor.scrbl"] @include-section["config.scrbl"] From a4078d52950e3619911e12483ad3e70c70990663 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Feb 2009 22:00:25 +0000 Subject: [PATCH 139/142] fix scribble/lp for check syntax svn: r13858 --- collects/scribble/lp/lang/lang.ss | 38 +++++++++++++++++-------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss index 05421233aa..7ecc7353d5 100644 --- a/collects/scribble/lp/lang/lang.ss +++ b/collects/scribble/lp/lang/lang.ss @@ -31,23 +31,27 @@ (define stupid-internal-definition-sytnax (unless first-id (raise-syntax-error 'scribble/lp "no chunks"))) + (define orig-stx (syntax-case stx () [(_ orig) #'orig])) + (define (restore nstx d) (datum->syntax orig-stx d nstx nstx)) + (define (shift nstx) (datum->syntax orig-stx (syntax-e nstx) nstx nstx)) (define body - (let loop ([block (if main-id - (get-chunk main-id) - (get-chunk first-id))]) - (append-map - (lambda (expr) - (if (identifier? expr) - (let ([subs (get-chunk expr)]) - (if (pair? subs) - (begin (set! chunk-mentions (cons expr chunk-mentions)) - (loop subs)) - (list expr))) - (let ([subs (syntax->list expr)]) - (if subs - (list (loop subs)) - (list expr))))) - block))) + (let ([main-id (or main-id first-id)]) + (restore + main-id + (let loop ([block (get-chunk main-id)]) + (append-map + (lambda (expr) + (if (identifier? expr) + (let ([subs (get-chunk expr)]) + (if (pair? subs) + (begin (set! chunk-mentions (cons expr chunk-mentions)) + (loop subs)) + (list (shift expr)))) + (let ([subs (syntax->list expr)]) + (if subs + (list (restore expr (loop subs))) + (list (shift expr)))))) + block))))) (with-syntax ([(body ...) body] ;; construct arrows manually [((b-use b-id) ...) @@ -82,4 +86,4 @@ (syntax-case expanded () [(module name lang (mb . stuff)) (begin (extract-chunks #'stuff) - #'(#%module-begin (tangle)))]))])) + #'(#%module-begin (tangle id)))]))])) From db70d62ca717d7602ec0fd0efe2dba9e15e9fe38 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Feb 2009 22:49:07 +0000 Subject: [PATCH 140/142] adjust scribble/lp docs svn: r13859 --- collects/scribblings/scribble/config.scrbl | 2 +- collects/scribblings/scribble/lp-ex-doc.scrbl | 4 ++ collects/scribblings/scribble/lp-ex.ss | 1 + collects/scribblings/scribble/lp.css | 4 ++ collects/scribblings/scribble/lp.scrbl | 49 +++++++++++++------ collects/scribblings/scribble/lp.tex | 3 ++ 6 files changed, 46 insertions(+), 17 deletions(-) create mode 100644 collects/scribblings/scribble/lp-ex-doc.scrbl create mode 100644 collects/scribblings/scribble/lp.css create mode 100644 collects/scribblings/scribble/lp.tex diff --git a/collects/scribblings/scribble/config.scrbl b/collects/scribblings/scribble/config.scrbl index 0d03105771..2f145316d5 100644 --- a/collects/scribblings/scribble/config.scrbl +++ b/collects/scribblings/scribble/config.scrbl @@ -58,7 +58,7 @@ To avoid collisions with future additions to Scribble, start your style name with an uppercase letter that is not @litchar{S}. An uppercase letter helps to avoid collisions with macros defined by Latex packages, and future styles needed by @scheme[scribble/manual] -will start with @litchar{s}. +will start with @litchar{S}. For example, a Scribble document diff --git a/collects/scribblings/scribble/lp-ex-doc.scrbl b/collects/scribblings/scribble/lp-ex-doc.scrbl new file mode 100644 index 0000000000..2d3bd6ae6f --- /dev/null +++ b/collects/scribblings/scribble/lp-ex-doc.scrbl @@ -0,0 +1,4 @@ +#lang scribble/doc +@(require scribble/lp-include) + +@lp-include["lp-ex.ss"] diff --git a/collects/scribblings/scribble/lp-ex.ss b/collects/scribblings/scribble/lp-ex.ss index 3fc74b37b2..34017c90e5 100644 --- a/collects/scribblings/scribble/lp-ex.ss +++ b/collects/scribblings/scribble/lp-ex.ss @@ -1,4 +1,5 @@ #lang scribble/lp + Literate programs have chunks of code, like this one: @chunk[ diff --git a/collects/scribblings/scribble/lp.css b/collects/scribblings/scribble/lp.css new file mode 100644 index 0000000000..638efcd2a1 --- /dev/null +++ b/collects/scribblings/scribble/lp.css @@ -0,0 +1,4 @@ +.LPBoxed { + padding: 1ex; + border: 1px solid #000000; +} diff --git a/collects/scribblings/scribble/lp.scrbl b/collects/scribblings/scribble/lp.scrbl index 83f1d6da19..5c457ec385 100644 --- a/collects/scribblings/scribble/lp.scrbl +++ b/collects/scribblings/scribble/lp.scrbl @@ -1,26 +1,34 @@ #lang scribble/doc -@(require scribble/manual scheme/runtime-path scribble/lp-include) +@(require scribble/manual + scribble/struct + scheme/runtime-path + (prefix-in lp-ex: "lp-ex-doc.scrbl") + "utils.ss" + (for-label scribble/lp-include + (only-in scribble/private/lp chunk))) -@title[#:tag "lp"]{Literate Programming} +@title[#:tag "lp" #:style `((css "lp.css") (tex "lp.tex")) ]{Literate Programming} Programs written using @schememodname[scribble/lp] are simultaneously -two things: a program, and a document describing the program. +two things: a program and a document describing the program. Programs in @schememodname[scribble/lp] are viewed in two different -ways, either by running the program directly, or by including it with -@scheme[include-lp]. When running the program, all of the +ways, either by running the program directly or by including it with +@scheme[lp-include]. When running the program, all of the @scheme[chunk] expressions are collected and stitched together into a -program and the rest of the module is discarded. When using -@scheme[include-lp], the entire contents of the module are preserved +program, and the rest of the module is discarded. When using +@scheme[lp-include], the entire contents of the module are preserved and are treated like an ordinary Scribble document, where @scheme[chunk]s are typeset in a manner similar to @scheme[codeblock]. @(define-runtime-path lp-ex "lp-ex.ss") For example, consider this program: + @(call-with-input-file lp-ex (lambda (port) (verbatim + #:indent 2 (apply string-append (let loop () @@ -36,25 +44,34 @@ function @scheme[f] that squares its argument, and the documentation is ignored. When it is included with @scheme[lp-include], it looks like this: -@lp-include["lp-ex.ss"] +@(make-blockquote + "LPBoxed" + (flow-paragraphs (part-flow lp-ex:doc))) -@section{@schememodname[scribble/lp] language} +@section{@schememodname[scribble/lp] Language} -@defmodulelang[scribble/lp]{This is a Scribble's core support for Literate Programming.} +@declare-exporting[scribble/private/lp] -@defform[(chunk expressions ...)]{ - Introduces a chunk, binding @scheme[] for use in other chunks. +@defmodulelang*/no-declare[(scribble/lp)]{The +@schememodname[scribble/lp] language provides core support for +literate programming.} - If @scheme[] is @tt{<*>}, then this chunk is used as the main - chunk in the file. If @tt{<*>} is never used, then the first chunk +@defform[(chunk id form ...)]{ + + Introduces a chunk, binding @scheme[id] for use in other + chunks. Normally, @scheme[id] starts with @litchar{<} and ends with + @litchar{>}. + + If @scheme[id] is @schemeidfont{<*>}, then this chunk is used as the main + chunk in the file. If @schemeidfont{<*>} is never used, then the first chunk in the file is treated as the main chunk. } -@section{@schememodname[scribble/lp-include] module} +@section{@schememodname[scribble/lp-include] Module} @defmodule[scribble/lp-include]{} @defform[(lp-include filename)]{ Includes the source of @scheme[filename] as the typeset version of the literate program. -} \ No newline at end of file +} diff --git a/collects/scribblings/scribble/lp.tex b/collects/scribblings/scribble/lp.tex new file mode 100644 index 0000000000..fcbaecac57 --- /dev/null +++ b/collects/scribblings/scribble/lp.tex @@ -0,0 +1,3 @@ + +\usepackage{framed} +\newenvironment{LPBoxed}{\begin{framed}}{\end{framed}} From cf005e3297f845dadedda0c6c55f86d2ec8bb661 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 26 Feb 2009 22:52:08 +0000 Subject: [PATCH 141/142] Adding unit/s and define-unit/s, which is the inferred version of unit-new-import-export etc. svn: r13860 --- collects/mzlib/unit.ss | 25 +++++++++++++++++++++- collects/scribblings/reference/units.scrbl | 22 +++++++++++++++++++ 2 files changed, 46 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index b93bc54627..546e8a033e 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1,6 +1,5 @@ (module unit mzscheme (require-for-syntax mzlib/list - scheme/pretty stxclass syntax/boundmap syntax/context @@ -31,6 +30,7 @@ unit-from-context define-unit-from-context define-unit-binding unit/new-import-export define-unit/new-import-export + unit/s define-unit/s unit/c define-unit/contract) (define-syntax/err-param (define-signature-form stx) @@ -1793,5 +1793,28 @@ (format "expected syntax matching (~a )" (syntax-e (stx-car stx))))))) + (define-for-syntax (build-unit/s stx) + (syntax-case stx (import export init-depend) + [((import i ...) (export e ...) (init-depend d ...) u) + (let* ([ui (lookup-def-unit #'u)] + [unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))]) + (lambda (p) + (unprocess-tagged-id (cons (car p) (i (cdr p))))))]) + (with-syntax ([(isig ...) (map unprocess (unit-info-import-sig-ids ui))] + [(esig ...) (map unprocess (unit-info-export-sig-ids ui))]) + (build-unit/new-import-export + (syntax/loc stx + ((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))])) + + (define-syntax/err-param (define-unit/s stx) + (build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx))) + "missing unit name")) + + (define-syntax/err-param (unit/s stx) + (syntax-case stx () + [(_ . stx) + (let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))]) + u)])) + ) ;(load "test-unit.ss") diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index 1f3cf4eb6b..d216800d16 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -578,6 +578,28 @@ each of the bindings implied by an @scheme[export] Like @scheme[unit/new-import-export], but binds static information to @scheme[unit-id] like @scheme[define-unit].} +@defform[ +#:literals (import export) +(unit/s + (import tagged-sig-spec ...) + (export tagged-sig-spec ...) + init-depends-decl + unit-id)]{ + +Like @scheme[unit/new-import-export], but the linking clause is +inferred, so @scheme[unit-id] must have the appropriate static +information.} +@defform[ +#:literals (import export) +(define-unit/s name-id + (import tagged-sig-spec ...) + (export tagged-sig-spec ...) + init-depends-decl + unit-id)]{ + +Like @scheme[unit/s], but binds static information to @scheme[name-id] +like @scheme[define-unit].} + @; ------------------------------------------------------------------------ @section[#:tag "define-sig-form"]{Extending the Syntax of Signatures} From 502427ee449ccbd2c1676f8b4e99ab23da5160cf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Feb 2009 22:57:06 +0000 Subject: [PATCH 142/142] add scribble/lp to complement scribble/lp/lang/reader svn: r13861 --- collects/scribble/lp.ss | 4 ++++ collects/scribblings/scribble/lp.scrbl | 10 +++------- 2 files changed, 7 insertions(+), 7 deletions(-) create mode 100644 collects/scribble/lp.ss diff --git a/collects/scribble/lp.ss b/collects/scribble/lp.ss new file mode 100644 index 0000000000..eebf6cd5a2 --- /dev/null +++ b/collects/scribble/lp.ss @@ -0,0 +1,4 @@ +#lang scheme + +(require scribble/private/lp) +(provide chunk) diff --git a/collects/scribblings/scribble/lp.scrbl b/collects/scribblings/scribble/lp.scrbl index 5c457ec385..9bf1ffe635 100644 --- a/collects/scribblings/scribble/lp.scrbl +++ b/collects/scribblings/scribble/lp.scrbl @@ -4,8 +4,7 @@ scheme/runtime-path (prefix-in lp-ex: "lp-ex-doc.scrbl") "utils.ss" - (for-label scribble/lp-include - (only-in scribble/private/lp chunk))) + (for-label scribble/lp-include scribble/lp)) @title[#:tag "lp" #:style `((css "lp.css") (tex "lp.tex")) ]{Literate Programming} @@ -50,11 +49,8 @@ like this: @section{@schememodname[scribble/lp] Language} -@declare-exporting[scribble/private/lp] - -@defmodulelang*/no-declare[(scribble/lp)]{The -@schememodname[scribble/lp] language provides core support for -literate programming.} +@defmodulelang[scribble/lp]{The @schememodname[scribble/lp] language +provides core support for literate programming.} @defform[(chunk id form ...)]{