suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge from trunk

Browse Source 
svn: r13863
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-27 00:16:53 +00:00
commit a0f275502d
835 changed files with 11190 additions and 7124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/2htdp/private/check-aux.ss
View File

@ -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]

7
collects/2htdp/private/universe.ss
View File

@ -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))
@ -228,9 +227,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)

45
collects/2htdp/private/world.ss
View File

@ -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
@ -168,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))))
@ -180,10 +173,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))
@ -269,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)

6
collects/2htdp/universe.ss
View File

@ -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 ()

63
collects/at-exp/lang/reader.ss Normal file
View File

@ -0,0 +1,63 @@
#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))
(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))

2
collects/browser/browser.scrbl
View File

@ -7,6 +7,8 @@
browser/htmltext
browser/external
browser/tool
scheme/base
scheme/class
scheme/gui/base
net/url
framework/framework))

8
collects/drscheme/private/module-language.ss
View File

@ -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
[()

7
collects/drscheme/private/rep.ss
View File

@ -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)])

14
collects/drscheme/private/unit.ss
View File

@ -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)))))])

124
collects/drscheme/syncheck.ss
View File

@ -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,14 +1851,14 @@ 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
identifier-binding
unused/phases
requires/phases
0
user-namespace
user-directory
#t))
@ -1855,14 +1867,14 @@ 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
identifier-transformer-binding
unused/phases
requires/phases
1
user-namespace
user-directory
#t))
@ -1875,36 +1887,36 @@ If the namespace does not, they are colored the unbound color.
(connect-identifier var
rename-ht
low-binders
unused-requires
requires
identifier-binding
unused/phases
requires/phases
0
user-namespace
user-directory
#f)
(connect-identifier var
rename-ht
high-binders
unused-require-for-syntaxes
require-for-syntaxes
identifier-transformer-binding
unused/phases
requires/phases
1
user-namespace
user-directory
#f)
(connect-identifier var
rename-ht
template-binders ;; dummy; always empty
unused-require-for-templates
require-for-templates
identifier-template-binding
unused/phases
requires/phases
-1
user-namespace
user-directory
#f)
(connect-identifier var
rename-ht
label-binders ;; dummy; always empty
unused-require-for-labels
require-for-labels
identifier-label-binding
unused/phases
requires/phases
#f
user-namespace
user-directory
#f))
@ -1952,7 +1964,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 +1972,20 @@ 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/phases requires/phases
phase-level user-namespace user-directory actual?)
(connect-identifier/arrow var all-binders
unused requires get-binding 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)))
;; 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,19 +2001,23 @@ 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/phases requires/phases 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))])
(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)
@ -2018,7 +2036,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)
@ -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)
@ -2064,11 +2090,11 @@ 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)
(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))

3
collects/ffi/objc.scrbl
View File

@ -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))

4
collects/file/gif.ss
View File

@ -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))

3
collects/framework/main.ss
View File

@ -1,5 +1,4 @@
#reader scribble/reader
#lang scheme/gui
#lang at-exp scheme/gui
(require mred/mred-unit
mred/mred-sig

6
collects/framework/private/text.ss
View File

@ -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^]

BIN
collects/games/chat-noir/5x5-empty-board.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 4.1 KiB

36
collects/games/chat-noir/README
View File

@ -2,44 +2,20 @@ 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.
- 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.
- 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?
- do unbound chunk ids signal syntax errors? How about unused ones?
- 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).
scribble/lp (when it is added).
scribble/lp-include

BIN
collects/games/chat-noir/cat-distance-example.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 13 KiB

3
collects/games/chat-noir/chat-noir-doc.ss
View File

@ -1,3 +0,0 @@
#lang scribble/doc
@(require "literate-doc-wrapper.ss")
@(include "chat-noir-literate.ss")

3466
collects/games/chat-noir/chat-noir-literate.ss
View File

File diff suppressed because it is too large Load Diff

5
collects/games/chat-noir/chat-noir-module.ss
View File

@ -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"))

41
collects/games/chat-noir/chat-noir-unit.ss
View File

@ -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)))

1628
collects/games/chat-noir/chat-noir.ss
View File

File diff suppressed because it is too large Load Diff

57
collects/games/chat-noir/literate-doc-wrapper.ss
View File

@ -1,57 +0,0 @@
#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.
(provide include chunk chunkref
(all-from-out scribble/manual))
(require scribble/manual scribble/decode scribble/struct scheme/include
(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)
(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))])
(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 ...)))))]))
(define-syntax (chunkref stx)
(syntax-case stx ()
[(_ id)
(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 ...))

103
collects/games/chat-noir/literate-lang.ss
View File

@ -1,103 +0,0 @@
#lang scheme/base
(provide (except-out (all-from-out scheme/base) #%module-begin)
(rename-out [module-begin #%module-begin])
chunk)
(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase))
(begin-for-syntax
(define main-id #f)
(define (mapping-get mapping id)
(free-identifier-mapping-get mapping id (lambda () '())))
;; maps a chunk identifier to its collected expressions
(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 (add-to-chunk! id exprs)
(unless main-id (set! main-id id))
(free-identifier-mapping-put!
chunk-groups id
(cons (syntax-local-introduce id) (mapping-get chunk-groups id)))
(free-identifier-mapping-put!
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
(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 expr)))
(let ([subs (syntax->list expr)])
(if subs
(list (loop subs))
(list expr)))))
block)))
(with-syntax ([(body ...) body]
;; construct arrows manually
[((b-use b-id) ...)
(append-map (lambda (m)
(map (lambda (u)
(list m (syntax-local-introduce u)))
(mapping-get chunk-groups m)))
chunk-mentions)])
#`(begin body ... (let ([b-id (void)]) b-use) ...)))
(define-syntax (module-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))]))]))])
#'(#%module-begin
body-code ...
(tangle)))]))

70
collects/games/scribblings/chat-noir.scrbl
View File

@ -1,69 +1,3 @@
#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")
@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[]
}
@(require scribble/lp-include)
@(lp-include "../chat-noir/chat-noir-literate.ss")

40
collects/games/scribblings/common.ss
View File

@ -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") ")."))

2
collects/games/scribblings/jewel.scrbl
View File

@ -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

3
collects/handin-server/checker.ss
View File

@ -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)))

173
collects/honu/main.ss
View File

@ -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)))

43
collects/htdp/image.ss
View File

@ -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)

137
collects/html/html-mod.ss Normal file
View File

@ -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))

12
collects/html/html-sig.ss
View File

@ -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^)

275
collects/html/html-unit.ss
View File

@ -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)))

2
collects/html/html.scrbl
View File

@ -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))

42
collects/html/html.ss
View File

@ -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)

8
collects/html/sgml-reader-sig.ss
View File

@ -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^)

801
collects/html/sgml-reader-unit.ss
View File

@ -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 "<!-~a" c))]))]
[(#\[) (read-char in)
(let ([s (read-string 6 in)])
(if (string=? s "CDATA[")
(let ([data (lex-cdata-contents in)])
(make-pcdata start (file-position in) data))
(make-pcdata start (file-position in) (format "<[~a" s))))]
[else (skip-dtd in) (lex in)])]
[(#\?) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(let ([data (lex-pi-data in)])
(make-pi start (file-position in) name data)))]
[(#\/) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(read-char in) ;; skip #\> 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)
(string<? (symbol->string (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 "<!-~a" c))]))]
[(#\[) (read-char in)
(let ([s (read-string 6 in)])
(if (string=? s "CDATA[")
(let ([data (lex-cdata-contents in)])
(make-pcdata start (file-position in) data))
(make-pcdata start (file-position in) (format "<[~a" s))))]
[else (skip-dtd in) (lex in)])]
[(#\?) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(let ([data (lex-pi-data in)])
(make-pi start (file-position in) name data)))]
[(#\/) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(read-char in) ;; skip #\> 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)
(string<? (symbol->string (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 "]]>")))

429
collects/html/sgml-reader.ss Normal file
View File

@ -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 "<!-~a" c))]))]
[(#\[) (read-char in)
(let ([s (read-string 6 in)])
(if (string=? s "CDATA[")
(let ([data (lex-cdata-contents in)])
(make-pcdata start (file-position in) data))
(make-pcdata start (file-position in) (format "<[~a" s))))]
[else (skip-dtd in) (lex in)])]
[(#\?) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(let ([data (lex-pi-data in)])
(make-p-i start (file-position in) name data)))]
[(#\/) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(read-char in) ;; skip #\> 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)
(string<? (symbol->string (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 "]]>"))

10
collects/lang/private/teach.ss
View File

@ -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)

5
collects/lazy/lazy.scrbl
View File

@ -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

8
collects/mrlib/switchable-button.ss
View File

@ -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

3
collects/mzlib/contract.ss
View File

@ -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

28
collects/mzlib/private/unit-contract.ss
View File

@ -3,6 +3,7 @@
(require (for-syntax scheme/base
stxclass
syntax/boundmap
syntax/name
"unit-compiletime.ss"
"unit-contract-syntax.ss"
"unit-syntax.ss")
@ -77,9 +78,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)))
@ -89,9 +94,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)))
@ -126,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
@ -217,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
@ -261,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))

14
collects/mzlib/private/unit-utils.ss
View File

@ -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)

96
collects/mzlib/unit.ss
View File

@ -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)
@ -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))))))
@ -790,30 +791,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))
@ -1277,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)))
@ -1476,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] ...) ...))))]
@ -1786,5 +1793,28 @@
(format "expected syntax matching (~a <define-unit-identifier>)"
(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")

4
collects/planet/lang/reader.ss
View File

@ -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)

13
collects/redex/private/arrow.ss
View File

@ -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

6
collects/redex/private/bitmap-test.ss
View File

@ -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)])

BIN
collects/redex/private/bmps/metafunction-Name-vertical.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.7 KiB

After

Width:  |  Height:  |  Size: 4.7 KiB

BIN
collects/redex/private/bmps/metafunction-Name.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.3 KiB

After

Width:  |  Height:  |  Size: 4.4 KiB

BIN
collects/redex/private/bmps/metafunction-TL.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.5 KiB

After

Width:  |  Height:  |  Size: 4.5 KiB

BIN
collects/redex/private/bmps/metafunctions-multiple.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 7.8 KiB

After

Width:  |  Height:  |  Size: 7.9 KiB

3
collects/redex/private/lw-test.ss
View File

@ -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))

11
collects/redex/private/pict.ss
View File

@ -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,7 +364,14 @@
[(>->) (basic-text "\u21a3" (default-style))]
[(~~>) (curvy-arrow-pict)]
[(~>) (short-curvy-arrow-pict)]
[(:->) (basic-text "\u21a6" (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))]

143
collects/redex/private/reduction-semantics.ss
View File

@ -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))
...))))]))
@ -519,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
@ -560,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
@ -614,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))]
@ -973,9 +978,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 ...)))
@ -1027,7 +1032,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))
@ -1141,7 +1146,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)

4
collects/redex/private/rewrite-side-conditions.ss
View File

@ -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))])

13
collects/redex/private/run-tests.ss
View File

@ -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)

10
collects/redex/private/tl-test.ss
View File

@ -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 ()

57
collects/redex/redex.scrbl
View File

@ -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

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "16feb2009")
#lang scheme/base (provide stamp) (define stamp "26feb2009")

4
collects/scheme/include.ss
View File

@ -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

22
collects/scheme/load.ss
View File

@ -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]))

5
collects/scheme/private/contract-arrow.ss
View File

@ -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)))

594
collects/scheme/private/contract.ss
View File

@ -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)
@ -88,31 +89,268 @@ 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]) . 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]
[type (if (identifier? #'name+arg-list) 'definition 'function)])
(syntax/loc define-stx
(with-contract #:type type name
([name 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 ...))]))
(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 "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 (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 ...))])
(unless (identifier? #'name)
(raise-syntax-error 'define-struct/contract
"expected identifier for struct name"
#'name))
(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 (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
"expected a list of field name/contract pairs"
#'bad-fields)]
[(_ . body)
(raise-syntax-error 'define-struct/contract
"expected a structure name"
#'body)]))
;
;
@ -148,149 +386,75 @@ 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-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 (p0 p ...) (u ...))
(raise-syntax-error 'with-contract
"no definition found for identifier"
#'p0)]
[(_ marker blame-stx () (u0 u ...))
[(_ blame-stx () (u0 u ...))
(raise-syntax-error 'with-contract
"no definition found for identifier"
#'u0)]
[(_ marker blame-stx ((p c) ...) (u ...) body0 body ...)
[(_ blame-stx (p ...) (u ...) body0 body ...)
(let ([expanded-body0 (local-expand #'body0
(syntax-local-context)
(cons #'splicing-syntax-parameterize
(kernel-form-identifier-list)))])
(syntax-case expanded-body0 (begin define-values)
(kernel-form-identifier-list))])
(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 marker blame-stx ((p c) ...) (u ...) 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)
(let*-values ([(marker-f) (let ([marker (syntax-e #'marker)])
(lambda (stx)
(syntax-local-introduce
(marker (syntax-local-introduce stx)))))]
[(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 (let ([marker (syntax-e #'marker)])
(lambda (stx)
(syntax-local-introduce
(marker (syntax-local-introduce stx)))))]
[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 ...))))]
(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-ps unused-us body ...)))))]
[else
(let*-values ([(marker-f) (let ([marker (syntax-e #'marker)])
(lambda (stx)
(syntax-local-introduce
(marker (syntax-local-introduce stx)))))])
(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 (p ...) (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 +463,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 +484,69 @@ 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
((-contract #,ctc
#,fv
#,pos-blame
#,neg-blame
#,(id->contract-src-info fv))
arg ...))]
[ident
(identifier? (syntax ident))
(quasisyntax/loc stx
(-contract #,ctc
#,fv
#,pos-blame
#,neg-blame
#,(id->contract-src-info fv)))]))))
(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 ...) . body)
(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)
(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 +554,73 @@ improve method arity mismatch contract violation error messages?
"identifier appears twice in exports"
dupd-id)))
(with-syntax ([blame-stx #''(type blame)]
[((p c) ...) (map list protected protections)]
[(u ...) unprotected])
[blame-id (car (generate-temporaries (list #t)))]
[(free-var ...) free-vars]
[(free-var-id ...) (map marker free-vars)]
[(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 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)]
[(u ...) unprotected]
[(marked-u ...) (map marker 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)]
[(_ #:type type blame (arg ...))
(identifier? #'blame)
(raise-syntax-error 'with-contract
"empty body"
stx)]
(begin
(define-values (free-ctc-id ...)
(values (verify-contract 'with-contract free-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)
(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 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)
...
(values)))
(define-syntaxes (u ... p ...)
(values (make-rename-transformer #'marked-u) ...
(make-with-contract-transformer
(quote-syntax ctc-id)
(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 ...) . body)
(syntax/loc stx
(with-contract #:type type blame (arg ...) #:freevars () . body))]
[(_ #: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"

8
collects/scheme/private/struct-info.ss
View File

@ -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)

49
collects/scheme/sandbox.ss
View File

@ -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)

24
collects/scribble/base-render.ss
View File

@ -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

4
collects/scribble/basic.ss
View File

@ -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)))

68
collects/scribble/html-render.ss
View File

@ -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]
@ -568,21 +572,34 @@
(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* ([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 "<!DOCTYPE html PUBLIC ~s ~s>\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,10 +609,16 @@
,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 ()
(body ((id ,(or (extract-part-body-id d ri)
"scribble-plt-scheme-org")))
,@(render-toc-view d ri)
(div ([class "maincolumn"])
(div ([class "main"])
@ -1011,8 +1034,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?)
@ -1021,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]
@ -1048,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
@ -1062,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;"])

138
collects/scribble/latex-render.ss
View File

@ -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)
@ -136,7 +145,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 +158,7 @@
'("!!!")))
(list "???")))
part ri)
(printf " ``"))
(printf "}{"))
(let ([style (and (element? e)
(let ([s (flatten-style (element-style e))])
(if (with-attributes? s)
@ -206,7 +215,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)))
@ -228,14 +237,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 +245,24 @@
[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}}"]
[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))]
@ -254,14 +272,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,15 +287,22 @@
(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])
(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))
@ -294,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)
(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")))
@ -305,27 +325,44 @@
(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)
(define/private (render-table-flow p part ri)
;; 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}{\\linewidth}\n"))
(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")
@ -405,6 +442,7 @@
[(#\u039B) "$\\Lambda$"]
[(#\u03BC) "$\\mu$"]
[(#\u03C0) "$\\pi$"]
[(#\∞) "$\\infty$"]
[else c])))
(loop (add1 i))))))

20
collects/scribble/lp-include.ss Normal file
View File

@ -0,0 +1,20 @@
#lang scheme/base
(require scheme/include (for-syntax scheme/base)
(only-in scribble/private/lp chunk)
scribble/manual)
(provide lp-include)
(define-syntax (module stx)
(syntax-case stx ()
[(module name base body ...)
(begin
#'(begin body ...))]))
(define-syntax (lp-include stx)
(syntax-case stx ()
[(_ name)
(with-syntax ([there (datum->syntax stx 'there)])
#'(include-at/relative-to here there name))]))

4
collects/scribble/lp.ss Normal file
View File

@ -0,0 +1,4 @@
#lang scheme
(require scribble/private/lp)
(provide chunk)

89
collects/scribble/lp/lang/lang.ss Normal file
View File

@ -0,0 +1,89 @@
#lang scheme/base
(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
syntax/strip-context))
(begin-for-syntax
(define first-id #f)
(define main-id #f)
(define (mapping-get mapping id)
(free-identifier-mapping-get mapping id (lambda () '())))
;; maps a chunk identifier to its collected expressions
(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) (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 id (mapping-get chunk-groups id)))
(free-identifier-mapping-put!
chunks id
`(,@(mapping-get chunks id) ,@exprs))))
(define-syntax (tangle stx)
(define chunk-mentions '())
(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 ([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) ...)
(append-map (lambda (m)
(map (lambda (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) ...)))
(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)
(let ([expanded
(expand `(,#'module scribble-lp-tmp-name scribble/private/lp
,@(strip-context #'(id exprs . body))))])
(syntax-case expanded ()
[(module name lang (mb . stuff))
(begin (extract-chunks #'stuff)
#'(#%module-begin (tangle id)))]))]))

2
collects/games/chat-noir/literate-reader.ss → collects/scribble/lp/lang/reader.ss
View File

@ -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

1
collects/scribble/manual.ss
View File

@ -14,6 +14,7 @@
(provide unsyntax
make-binding-redirect-elements
defidentifier
(all-from-out "basic.ss"
"private/manual-style.ss"
"private/manual-scheme.ss"

4
collects/scribble/manual/lang.ss Normal file
View File

@ -0,0 +1,4 @@
#lang scheme
(require scribble/doclang scribble/manual)
(provide (all-from-out scribble/doclang
scribble/manual))

10
collects/scribble/manual/lang/reader.ss Normal file
View File

@ -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"))

82
collects/scribble/private/lp.ss Normal file
View File

@ -0,0 +1,82 @@
#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)
(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))]
[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 ...)))
(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 ([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
scribble/manual)
chunk)

32
collects/scribble/private/manual-bind.ss
View File

@ -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))])

19
collects/scribble/private/manual-class.ss
View File

@ -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

2
collects/scribble/private/manual-form.ss
View File

@ -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

11
collects/scribble/private/manual-proc.ss
View File

@ -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

2
collects/scribble/private/manual-style.ss
View File

@ -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

6
collects/scribble/private/manual-tech.ss
View File

@ -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)

31
collects/scribble/private/manual-vars.ss
View File

@ -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)))])

5
collects/scribble/run.ss
View File

@ -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 <name>"
(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 <url>"
@ -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)

201
collects/scribble/scheme.ss
View File

@ -20,9 +20,14 @@
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
variable-id?
make-element-id-transformer
element-id-transformer?))
(define no-color "schemeplain")
(define reader-color "schemereader")
@ -118,57 +123,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,48 +601,65 @@
(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-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
[(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 ()
[(_ 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)
@ -666,6 +694,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))

1
collects/scribble/scribble-prefix.html Normal file
View File

@ -0,0 +1 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">

11
collects/scribble/scribble-prefix.tex Normal file
View File

@ -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

22
collects/scribble/scribble.tex
View File

@ -1,20 +1,10 @@
% 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}
\usepackage{longtable}
\usepackage{relsize}
\usepackage[htt]{hyphenat}
\usepackage[usenames,dvipsnames]{color}
\hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true}
@ -67,8 +57,9 @@
\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{\planetName}[1]{PLane\hspace{-0.1ex}T}
\newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle}
\newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle}
@ -86,7 +77,8 @@
\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''}
\newcommand{\sectionhidden}[1]{\section{#1}}
\newcommand{\subsectionhidden}[1]{\subsection{#1}}

3
collects/scribble/text-render.ss
View File

@ -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)

2
collects/scribblings/htdp-langs/advanced.scrbl
View File

@ -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|.}

2
collects/scribblings/htdp-langs/beginner-abbr.scrbl
View File

@ -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|.}

7
collects/scribblings/htdp-langs/beginner.scrbl
View File

@ -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 ...))]{

2
collects/scribblings/htdp-langs/intermediate-lambda.scrbl
View File

@ -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|.}

2
collects/scribblings/htdp-langs/intermediate.scrbl
View File

@ -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|.}

8
collects/scribblings/reference/class.scrbl
View File

@ -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.}
@; ------------------------------------------------------------------------

53
collects/scribblings/reference/contracts.scrbl
View File

@ -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]
@ -689,20 +693,43 @@ 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.
@defform*[[(define/contract id contract-expr init-value-expr)
(define/contract (head args) contract-expr body ...+)]]{
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 ...+)]]{
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].
For the definition of @scheme[free-var-list], see @scheme[with-contract].
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.
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[define/contract] form for the positive
positions and the @scheme[define/contract] form for the negative ones.}
@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)

6
collects/scribblings/reference/include.scrbl
View File

@ -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.

3
collects/scribblings/reference/module-reflect.scrbl
View File

@ -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?

Some files were not shown because too many files have changed in this diff Show More