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

sync to trunk

Browse Source 
svn: r17249
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-09 19:44:12 +00:00
commit cd0a94d465
185 changed files with 7606 additions and 3153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/2htdp/image.ss
View File

@ -52,6 +52,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(provide overlay
overlay/align
overlay/xy
underlay
underlay/align
underlay/xy
beside
beside/align

28
collects/2htdp/private/image-more.ss
View File

@ -307,10 +307,14 @@
;; overlay : image image image ... -> image
;; places images on top of each other with their upper left corners aligned. last one goes on the bottom
(define/chk (overlay image image2 . image3)
(overlay/internal 'left 'top image (cons image2 image3)))
;; underlay : image image image ... -> image
(define (underlay image image2 . image3)
(let ([imgs (reverse (list* image image2 image3))])
(overlay/internal 'left 'top (car imgs) (cdr imgs))))
;; overlay/align : string string image image image ... -> image
;; the first string has to be one of "center" "middle" "left" or "right" (or symbols)
;; the second string has to be one of "center" "middle" "top" "bottom" or "baseline" (or symbols)
@ -322,6 +326,10 @@
(define/chk (overlay/align x-place y-place image image2 . image3)
(overlay/internal x-place y-place image (cons image2 image3)))
(define/chk (underlay/align x-place y-place image image2 . image3)
(let ([imgs (reverse (list* image image2 image3))])
(overlay/internal x-place y-place (car imgs) (cdr imgs))))
(define (overlay/internal x-place y-place fst rst)
(let loop ([fst fst]
[rst rst])
@ -346,14 +354,16 @@
(case x-place
[(left) 0]
[(middle) (/ (image-right image) 2)]
[(right) (image-right image)]))
[(right) (image-right image)]
[else (error 'find-x-spot "~s" x-place)]))
(define (find-y-spot y-place image)
(case y-place
[(top) 0]
[(middle) (/ (image-bottom image) 2)]
[(bottom) (image-bottom image)]
[(baseline) (image-baseline image)]))
[(baseline) (image-baseline image)]
[else (error 'find-y-spot "~s" y-place)]))
;; overlay/xy : image number number image -> image
;; places images on top of each other with their upper-left corners offset by the two numbers
@ -366,6 +376,14 @@
(if (< dx 0) 0 dx)
(if (< dy 0) 0 dy)))
(define/chk (underlay/xy image dx dy image2)
(overlay/δ image2
(if (< dx 0) 0 dx)
(if (< dy 0) 0 dy)
image
(if (< dx 0) (- dx) 0)
(if (< dy 0) (- dy) 0)))
(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2)
(make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
(make-translate dx2 dy2 (image-shape image2)))
@ -943,6 +961,10 @@
(provide overlay
overlay/align
overlay/xy
underlay
underlay/align
underlay/xy
beside
beside/align
above

5
collects/2htdp/private/stop.ss Normal file
View File

@ -0,0 +1,5 @@
#lang scheme
(provide (struct-out stop-the-world))
(define-struct stop-the-world (world) #:transparent)

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

@ -4,6 +4,7 @@
"timer.ss"
"last.ss"
"checked-cell.ss"
"stop.ss"
htdp/image
htdp/error
mzlib/runtime-path
@ -219,16 +220,26 @@
(when (package? nw)
(broadcast (package-message nw))
(set! nw (package-world nw)))
(let ([changed-world? (send world set tag nw)])
(unless changed-world?
(when draw (pdraw))
(when (pstop)
(when last-picture
(set! draw last-picture)
(pdraw))
(callback-stop! 'name)
(enable-images-button)))
changed-world?))))))
(if (stop-the-world? nw)
(begin
(set! nw (stop-the-world-world nw))
(send world set tag nw)
(when last-picture
(set! draw last-picture))
(when draw (pdraw))
(callback-stop! 'name)
(enable-images-button))
(let ([changed-world? (send world set tag nw)])
(unless changed-world?
(when draw (pdraw))
(when (pstop)
(printf "!stop!\n")
(when last-picture
(set! draw last-picture)
(pdraw))
(callback-stop! 'name)
(enable-images-button)))
changed-world?)))))))
;; tick, tock : deal with a tick event for this world
(def/pub-cback (ptock) tick)
@ -284,7 +295,11 @@
;; initialize the world and run
(super-new)
(start!)
(when (stop (send world get)) (stop! (send world get)))))))
(let ([w (send world get)])
(cond
[(stop w) (stop! (send world get))]
[(stop-the-world? w)
(stop! (stop-the-world-world (send world get)))]))))))
;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png"))

22
collects/2htdp/tests/stop.ss Normal file
View File

@ -0,0 +1,22 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname test-stop) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require 2htdp/universe)
;; on RETURN stop
(define (main debug?)
(big-bang ""
(on-key (lambda (w ke)
(cond
[(key=? ke "\r") (stop-with w)]
[(= (string-length ke) 1)
(string-append w ke)]
[else w])))
(state debug?)
(on-draw (lambda (w)
(place-image
(text w 22 'black)
3 3
(empty-scene 100 100))))))

172
collects/2htdp/tests/test-image.ss
View File

@ -285,9 +285,9 @@
#f))
(test (overlay/align 'middle
'middle
(ellipse 100 50 'solid 'green)
(ellipse 50 100 'solid 'red))
'middle
(ellipse 100 50 'solid 'green)
(ellipse 50 100 'solid 'red))
=>
(make-image
(make-overlay
@ -297,9 +297,9 @@
#f))
(test (overlay/align 'middle
'middle
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
'middle
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
=>
(make-image
(make-overlay
@ -310,9 +310,9 @@
(test (overlay/align 'right
'bottom
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
'bottom
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
=>
(make-image
(make-overlay
@ -322,9 +322,9 @@
#f))
(test (overlay/align 'right
'baseline
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
'baseline
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
=>
(make-image
(make-overlay
@ -413,13 +413,136 @@
#f))
(test (above (ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'blue))
(ellipse 100 50 'solid 'blue))
=>
(above/align 'left
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'blue)))
(test (underlay (ellipse 100 100 'solid 'blue)
(ellipse 120 120 'solid 'red))
=>
(make-image
(make-overlay
(make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red)))
(make-translate 0 0 (image-shape (ellipse 100 100 'solid 'blue))))
(make-bb 120
120
120)
#f))
(test (underlay/xy (ellipse 100 100 'solid 'blue)
0 0
(ellipse 120 120 'solid 'red))
=>
(underlay (ellipse 100 100 'solid 'blue)
(ellipse 120 120 'solid 'red)))
(test (underlay/xy (ellipse 50 100 'solid 'red)
-25 25
(ellipse 100 50 'solid 'green))
=>
(make-image
(make-overlay
(make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))
(make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))))
(make-bb 100
100
100)
#f))
(test (underlay/xy (ellipse 100 50 'solid 'green)
10 10
(ellipse 50 100 'solid 'red))
=>
(make-image
(make-overlay
(make-translate 10 10 (image-shape (ellipse 50 100 'solid 'red)))
(make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green))))
(make-bb 100
110
110)
#f))
(test (underlay (ellipse 100 50 'solid 'green)
(ellipse 50 100 'solid 'red))
=>
(make-image
(make-overlay
(make-translate 0 0 (image-shape (ellipse 50 100 'solid 'red)))
(make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green))))
(make-bb 100
100
100)
#f))
(test (underlay (ellipse 100 100 'solid 'blue)
(ellipse 120 120 'solid 'red)
(ellipse 140 140 'solid 'green))
=>
(make-image
(make-overlay
(make-translate
0 0
(make-overlay
(make-translate 0 0 (image-shape (ellipse 140 140 'solid 'green)))
(make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red)))))
(make-translate 0 0 (image-shape (ellipse 100 100 'solid 'blue))))
(make-bb 140 140 140)
#f))
(test (underlay/align 'middle
'middle
(ellipse 100 50 'solid 'green)
(ellipse 50 100 'solid 'red))
=>
(make-image
(make-overlay
(make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))
(make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))))
(make-bb 100 100 100)
#f))
(test (underlay/align 'middle
'middle
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
=>
(make-image
(make-overlay
(make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))
(make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))))
(make-bb 100 100 100)
#f))
(test (underlay/align 'right
'bottom
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
=>
(make-image
(make-overlay
(make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green)))
(make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))))
(make-bb 100 100 100)
#f))
(test (underlay/align "right"
"baseline"
(ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'green))
=>
(make-image
(make-overlay
(make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green)))
(make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red))))
(make-bb 100 100 100)
#f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing normalization
@ -831,3 +954,26 @@
16)
(check-equal? (image-height (bitmap icons/stop-16x16.png))
16)
(check-equal? (let ()
(define bmp (make-object bitmap% 4 4))
(define mask (make-object bitmap% 4 4))
(define bdc (make-object bitmap-dc% bmp))
(send bdc set-brush "black" 'solid)
(send bdc draw-rectangle 0 0 4 4)
(send bdc set-bitmap mask)
(send bdc set-brush "black" 'solid)
(send bdc clear)
(send bdc draw-rectangle 1 1 1 1)
(send bdc set-bitmap #f)
(let-values ([(bytes w h) (bitmap->bytes bmp mask)])
bytes))
(bytes-append #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0"
#"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0"
#"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0"
#"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0"))
;; ensure no error
(check-equal? (begin (scale 2 (make-object bitmap% 10 10))
(void))
(void))

10
collects/2htdp/tests/world0-stops.ss
View File

@ -1,5 +1,13 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp")))))
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require 2htdp/universe)
"does big-bang stop when the initial world is already a final world?"
(big-bang 0 (stop-when zero?) (on-tick add1))
"does big bang stop when the initial world is a stop world?"
(big-bang (stop-with 0) (on-tick add1))
(define-struct stop (x))

4
collects/2htdp/universe.ss
View File

@ -17,11 +17,15 @@
"private/world.ss"
"private/universe.ss"
"private/launch-many-worlds.ss"
"private/stop.ss"
htdp/error
(rename-in lang/prim (first-order->higher-order f2h)))
(provide (all-from-out "private/image.ss"))
(provide
(rename-out (make-stop-the-world stop-with))) ;; World -> STOP
(provide
launch-many-worlds
;; (launch-many-worlds e1 ... e2)

47
collects/algol60/bd-tool.ss
View File

@ -1,35 +1,12 @@
(module bd-tool mzscheme
(require framework/private/decode)
(decode 05c1dd6edc460c06d057f9226301b2e86c5c23690103a9835c
e53a0f50602852d2ecce8f324379adb7ef3924b6a60aeaf6fb
48dd403909a6d24daf634c984a379d189493609a731ce33ac6
c4a09c04d351935fc79818949360f2d6f2758c0993f6316f56
6c6206a92da91a7a133983683cdf40d91c440a1a36b7aa23fc
abd10d341fbd5bf5306c6e550733332856057d0369740ba555
dfa08c7f18f40da4d12d683ca18c17666690da92aa41d21aa4
806255f4267206d178be814abc5b6872b3d921c94bdc2f2039
52d6b047df4073cbd9664fad863dfa8629e6b5e5bf9f27c624
7abdedebc4cc0c525b5235e4e49e2d4801c5aae84de40ca2f1
7c0365f33f40240554e2dd42939bcd0e495ee27e017d060dab
0a496b9082d53c3c92fac6f8c2a0cfa0615521690d52b09a87
cdd2ba39e30b338374069578b7d0e466b3439297b8079d2f90
c2cca06155a13386791873cc86e7ebcb573c5f5fbe32685855
e80cedf1112479893b24ad410a9ef1cca06155a133867990e4
25ee785a18529819b4f7f69ed4e0ade5ef0c525b52b570d4e4
f0d6f277502a7beb0eed63deacd8abb796ff63907decad3bb4
8f79b362afde5a0ef6b1b7eee33f06a92da91af62d0efb0bef
2d2983d496540dfb1687bde0bd256590da92aa814abc5ba8f6
08474d1e961e8b5d308eddfa8541738e63601cbbf50b28d5cd
7a72ace6410ef756c31eab65068d63b71e521d1eaba7e80662
06a92da91ae4706f1594eaf0583d4537c8e1deea0594937bb6
2005b49a0739dc5b0d7bac96199463118d2039dc5b85bd3b83
b239881454e2dd42939bcd0e4d31b7f582e967dcf7133f52f7
4de3f9277e3591f3d384a785994125de2d34b9d9ec2836465c
ed02496b9002655089770b4d6e363be4706ff582e967dcf713
3f52f74de3895f4de4fc3441413916d108121883865585626c
ed81a78519f4fb686e20695dad333368585528c6d61e787266
66d0f0331be8f7d1dc406ad9dc94999941c3aa8256f320877b
ab618fd53263de625d2dcc5bcadaad82722ca211941934b73a
20877babc8cccc0c7a6c56d19bc81944e3f906d23ee6cd8abd
aee69fedc3adeaab7db8550d474d1e961e8ba1c4bb856a8f70
d4e461e9b1d8054f0b33f3ff))
#lang s-exp framework/private/decode
bVTbjtsgEP2VqatIdlWyadSLtFIv6lOf+wErgZkYthi8gJPN33cAO3GyfonjM2fOXDi49vgy
ao9QGy2g6j3KbQhV+Vc1E9waHkLCZ2C0Oi7fo3Om5EkfWoU9Vg3FJB60RfBOiDMTkp9/Eh8j
1LWEOmDrrAzsh+SR6rej92gjm+CmSQLcEvE7CRGF9c5GBbKBb80VJNEE7Qt/Kih0x0Rf0m+K
9/wfMieesY1Eij0fNlCLURvJBk7ideuMoaB2tgAVN50zX3c0aSXk9nnoqptKRsdocL0YTfqB
Rk2x1boPaQeUNHXbYWQnLaNq4HOzGlWoOxVTOHfQruky2W5A9JmR84kWKDe03CDstvsv+WcR
lZ6fWEmei+1gd5c+xd8fmll88O6oJUI6+l+XhbDkjIJBrfvB+QizJR4T/ERUfH2LswKGp+tu
B8UDfoKj0/IO3N+BZQ8WT7k8O3je4wbCOKDfECvbd3qlrqxCT02mjYoxxnzUFk2aOFGYtiFy
G3W25dJVmZwErvGCbdI1uBhhRdjwnkyRrJYl8BibxU1YnqLU3LhuA9UfPgxn+K19VGSnj/A3
WetdlY4g9bTM6TEE3tHE0/HJu/jc5J3mRVIuGgS8nDwE5U65HtQvo0vbEM5L9AtzTZxYLkWI
ZzLZTJZIE6Jsmit/ZTet4rZD1iq6hPQBuLaS9kafgjDv3UxCJ0Wsm4t2MRKpP+BrpEqP5bHw
A6x6JG/zPw==

31
collects/at-exp/lang/reader.ss
View File

@ -14,18 +14,19 @@
(apply p args))))
(define-values (at-read at-read-syntax at-get-info)
(make-meta-reader 'at-exp
"language path"
(lambda (str)
(let ([s (string->symbol
(string-append (bytes->string/latin-1 str)
"/lang/reader"))])
(and (module-path? s) s)))
wrap-reader
wrap-reader
(lambda (proc)
(lambda (key defval)
(case key
[(color-lexer)
(dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
[else (if proc (proc key defval) defval)]))))))
(make-meta-reader
'at-exp
"language path"
(lambda (str)
(let ([s (string->symbol
(string-append (bytes->string/latin-1 str)
"/lang/reader"))])
(and (module-path? s) s)))
wrap-reader
wrap-reader
(lambda (proc)
(lambda (key defval)
(case key
[(color-lexer)
(dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
[else (if proc (proc key defval) defval)]))))))

704
collects/browser/browser.scrbl
View File

@ -23,24 +23,24 @@
@title{@bold{Browser}: Simple HTML Rendering}
The @schememodname[browser] library provides the following
procedures and classes for parsing and viewing HTML files. The
@schememodname[browser/htmltext] library provides a simplified
interface for rendering to a subclass of the MrEd @scheme[text%]
class. The @schememodname[browser/external] library provides utilities
for launching an external browser (such as Firefox).
The @schememodname[browser] library provides the following procedures
and classes for parsing and viewing HTML files. The
@schememodname[browser/htmltext] library provides a simplified interface
for rendering to a subclass of the MrEd @scheme[text%] class. The
@schememodname[browser/external] library provides utilities for
launching an external browser (such as Firefox).
@section[#:tag "browser"]{Browser}
@defmodule[browser]
The browser supports basic HTML commands, plus special Scheme
hyperlinks of the form @(litchar "<A MZSCHEME=sexpr>...</A>"). When
the user clicks on such a link, the string @scheme[sexpr] is parsed as
a Scheme program and evaluated. Since @scheme[sexpr] is likely to
contain Scheme strings, and since escape characters are difficult for
people to read, a @litchar{|} character in @scheme[sexpr] is
converted to a @litchar{"} character before it is parsed. Thus,
The browser supports basic HTML commands, plus special Scheme hyperlinks
of the form @litchar{<A MZSCHEME=sexpr>...</A>}. When the user clicks
on such a link, the string @scheme[sexpr] is parsed as a Scheme program
and evaluated. Since @scheme[sexpr] is likely to contain Scheme
strings, and since escape characters are difficult for people to read, a
@litchar{|} character in @scheme[sexpr] is converted to a @litchar{"}
character before it is parsed. Thus,
@verbatim[#:indent 2]{
<A MZSCHEME="|This goes nowhere.|">Nowhere</A>
@ -49,214 +49,211 @@ converted to a @litchar{"} character before it is parsed. Thus,
creates a ``Nowhere'' hyperlink, which executes the Scheme program
@schemeblock[
"This goes nowhere."
"This goes nowhere."
]
The value of that program is a string. When a Scheme hyperlink returns
a string, it is parsed as a new HTML document. Thus, where the use
The value of that program is a string. When a Scheme hyperlink returns
a string, it is parsed as a new HTML document. Thus, where the use
clicks on ``Nowhere,'' the result is a new page that says ``This goes
nowhere.''
The browser also treats comment forms containing @(litchar "MZSCHEME=sexpr")
specially. Whereas the @(litchar "<A MZSCHEME=sexpr>...</A>") form executes the
expression when the user clicks, the @(litchar "MZSCHEME") expression in a comment
is executed immediately during HTML rendering. If the result is a
string, the comment is replaced in the input HTML stream with the
content of the string. Thus,
The browser also treats comment forms containing
@litchar{MZSCHEME=sexpr} specially. Whereas the
@litchar{<A MZSCHEME=sexpr>...</A>} form executes the expression when
the user clicks, the @litchar{MZSCHEME} expression in a comment is
executed immediately during HTML rendering. If the result is a string,
the comment is replaced in the input HTML stream with the content of the
string. Thus,
@verbatim[#:indent 2]{
<!-- MZSCHEME="(format |<B>Here</B>: ~a| (current-directory))" -->
}
inserts the path of the current working directory into the containing
document (and ``Here'' is boldfaced). If the result is a snip instead
of a string, it replaces the comment in the document. Other types of
document (and ``Here'' is boldfaced). If the result is a snip instead
of a string, it replaces the comment in the document. Other types of
return values are ignored.
If the html file is being accessed as a @(litchar "file:") url, the
If the html file is being accessed as a @litchar{file:} url, the
@scheme[current-load-relative-directory] parameter is set to the
directory during the evaluation of the mzscheme code (in both
examples). The Scheme code is executed through @scheme[eval].
examples). The Scheme code is executed through @scheme[eval].
The @(litchar "MZSCHEME") forms are disabled unless the web page is a
@(litchar "file:") url that points into the @scheme[doc] collection.
The @litchar{MZSCHEME} forms are disabled unless the web page is a
@litchar{file:} url that points into the @scheme[doc] collection.
@defproc[(open-url [url (or/c url? string? input-port?)]) (is-a?/c hyper-frame%)]{
Opens the given url
in a vanilla browser frame and returns
the frame. The frame is an instance of
@scheme[hyper-frame%].
Opens the given url in a vanilla browser frame and returns the
frame. The frame is an instance of @scheme[hyper-frame%].
}
@defboolparam[html-img-ok ok?]{
A parameter that determines whether the browser attempts to
download and render images.
A parameter that determines whether the browser attempts to download
and render images.
}
@defboolparam[html-eval-ok ok?]{
A parameter that determines whether @(litchar "MZSCHEME=")
tags are evaluated.
A parameter that determines whether @litchar{MZSCHEME=} tags are
evaluated.
}
@; ----------------------------------------------------------------------
@defmixin[hyper-frame-mixin (frame%) ()]{
@defconstructor/auto-super[([url (or/c url? string? input-port?)])]{
Shows the frame and visits @scheme[url].
}
@defconstructor/auto-super[([url (or/c url? string? input-port?)])]{
Shows the frame and visits @scheme[url].
}
@defmethod[(get-hyper-panel%) (subclass?/c panel%)]{
Returns the class that is instantiated when the frame is created.
Must be a panel with hyper-panel-mixin mixed in. Defaults to
just returning @scheme[hyper-panel%].
}
@defmethod[(get-hyper-panel%) (subclass?/c panel%)]{
Returns the class that is instantiated when the frame is created.
Must be a panel with hyper-panel-mixin mixed in. Defaults to just
returning @scheme[hyper-panel%].
}
@defmethod[(get-hyper-panel) (is-a?/c panel%)]{
Returns the hyper panel in this frame.
}
@defmethod[(get-hyper-panel) (is-a?/c panel%)]{
Returns the hyper panel in this frame.
}
}
@; ----------------------------------------------------------------------
@defclass[hyper-no-show-frame% (hyper-frame-mixin (frame:status-line-mixin frame:basic%)) ()]
@defclass[hyper-no-show-frame%
(hyper-frame-mixin (frame:status-line-mixin frame:basic%))
()]
@; ----------------------------------------------------------------------
@defmixin[hyper-no-show-frame-mixin (frame%) ()]{
The same as the @scheme[hyper-frame-mixin], except that it
doesn't show the frame and the initialization arguments
are unchanged.
The same as the @scheme[hyper-frame-mixin], except that it doesn't
show the frame and the initialization arguments are unchanged.
}
@; ----------------------------------------------------------------------
@defclass[hyper-frame% (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%)) ()]
@defclass[hyper-frame%
(hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%))
()]
@; ----------------------------------------------------------------------
@defmixin[hyper-text-mixin (text%) ()]{
An instance of a @scheme[hyper-text-mixin]-extended class
should be displayed only in an instance of a class created
with @scheme[hyper-canvas-mixin].
An instance of a @scheme[hyper-text-mixin]-extended class should be
displayed only in an instance of a class created with
@scheme[hyper-canvas-mixin].
@defconstructor/auto-super[([url (or/c url? string? input-port?)]
[status-frame (or/c (is-a?/c top-level-window<%>) false/c)]
[post-data (or/c false/c bytes?)])]{
The @scheme[url] is loaded into the @scheme[text%] object
(using the @method[hyper-text-mixin reload] method), a
top-level window for status messages and dialogs, a progress
procedure used as for @scheme[get-url], and either @scheme[#f]
or a post string to be sent to a web server (technically
changing the GET to a POST).
@defconstructor/auto-super[([url (or/c url? string? input-port?)]
[status-frame
(or/c (is-a?/c top-level-window<%>) false/c)]
[post-data (or/c false/c bytes?)])]{
The @scheme[url] is loaded into the @scheme[text%] object (using the
@method[hyper-text-mixin reload] method), a top-level window for
status messages and dialogs, a progress procedure used as for
@scheme[get-url], and either @scheme[#f] or a post string to be sent
to a web server (technically changing the GET to a POST).
Sets the autowrap-bitmap to @scheme[#f].
}
Sets the autowrap-bitmap to @scheme[#f].
}
@defmethod[(map-shift-style [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[shift-style style<%>])
void?]{
Maps the given style over the given range.
}
@defmethod[(map-shift-style [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[shift-style style<%>])
void?]{
Maps the given style over the given range.
}
@defmethod[(make-link-style [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?])
void?]{
Changes the style for the given range to the link style.
}
@defmethod[(make-link-style [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?])
void?]{
Changes the style for the given range to the link style.
}
@defmethod[(get-url) (or/c url? string? input-port? false/c)]{
Returns the URL displayed by the editor, or @scheme[#f] if there
is none.
}
@defmethod[(get-url) (or/c url? string? input-port? false/c)]{
Returns the URL displayed by the editor, or @scheme[#f] if there is
none.
}
@defmethod[(get-title) string?]{
Gets the page's title.
}
@defmethod[(get-title) string?]{
Gets the page's title.
}
@defmethod[(set-title [str string?]) void?]{
Sets the page's title.
}
@defmethod[(set-title [str string?]) void?]{
Sets the page's title.
}
@defmethod[(hyper-delta) style-delta%]{
Override this method to set the link style.
}
@defmethod[(hyper-delta) style-delta%]{
Override this method to set the link style.
}
@defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{
Installs a tag.
}
@defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{
Installs a tag.
}
@defmethod[(find-tag [name/number (or/c string? exact-nonnegative-integer?)])
(or/c exact-nonnegative-integer? false/c)]{
Finds the location of a tag in the buffer (where tags
are installed in HTML with @(litchar "<A
NAME=\"name\">")) and returns its position. If
@scheme[name] is a number, the number is returned
(assumed to be an offset rather than a
tag). Otherwise, if the tag is not found, @scheme[#f]
is returned.
}
@defmethod[(find-tag [name/number (or/c string? exact-nonnegative-integer?)])
(or/c exact-nonnegative-integer? false/c)]{
Finds the location of a tag in the buffer (where tags are installed
in HTML with @litchar{<A NAME="name">}) and returns its position.
If @scheme[name] is a number, the number is returned (assumed to be
an offset rather than a tag). Otherwise, if the tag is not found,
@scheme[#f] is returned.
}
@defmethod[(remove-tag [name string?]) void?]{
Removes a tag.
}
@defmethod[(remove-tag [name string?]) void?]{
Removes a tag.
}
@defmethod[(post-url [url (or/c string? url?)]
[post-data-bytes (or/c bytes? false/c) #f]) void?]{
Follows the link, optionally with the given post data.
}
@defmethod[(post-url [url (or/c string? url?)]
[post-data-bytes (or/c bytes? false/c) #f]) void?]{
Follows the link, optionally with the given post data.
}
@defmethod[(add-link [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[url (or/c url? string?)])
void?]{
Installs a hyperlink.
}
@defmethod[(add-link [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[url (or/c url? string?)])
void?]{
Installs a hyperlink.
}
@defmethod[(add-scheme-callback [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[scheme-expr string?])
void?]{
Installs a Scheme evaluation hyperlink.
}
@defmethod[(add-scheme-callback [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[scheme-expr string?])
void?]{
Installs a Scheme evaluation hyperlink.
}
@defmethod[(add-thunk-callback [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[thunk (-> any)])
void?]{
Installs a thunk-based hyperlink.
}
@defmethod[(add-thunk-callback [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[thunk (-> any)])
void?]{
Installs a thunk-based hyperlink.
}
@defmethod[(eval-scheme-string [str string?]) any]{
Called to handle the @(litchar "<A MZSCHEME=\"expr\">...</A>")
tag and @(litchar "<! MZSCHEME=\"expr\">") comments (see above).
Evaluates the string; if the result is a string,
it is opened as an HTML page.
}
@defmethod[(eval-scheme-string [str string?]) any]{
Called to handle the @litchar{<A MZSCHEME="expr">...</A>} tag and
@litchar{<! MZSCHEME="expr">} comments (see above). Evaluates the
string; if the result is a string, it is opened as an HTML page.
}
@defmethod[(reload) void?]{
Reloads the current page.
@defmethod[(reload) void?]{
Reloads the current page.
The text defaultly uses the basic style named
@scheme["Html Standard"] in the editor (if it exists).
}
The text defaultly uses the basic style named
@scheme["Html Standard"] in the editor (if it exists).
}
@defmethod[(remap-url [url (or/c url? string?)]) (or/c url? string?)]{
When visiting a new page, this method is called to remap
the url. The remapped url is used in place of the
original url. If this method returns @scheme[#f], the page doesn't
go anywhere.
@defmethod[(remap-url [url (or/c url? string?)]) (or/c url? string?)]{
When visiting a new page, this method is called to remap the url.
The remapped url is used in place of the original url. If this
method returns @scheme[#f], the page doesn't go anywhere.
This method may be killed (if the user clicks the
``stop'' button).
}
@defmethod[(get-hyper-keymap) (is-a?/c keymap%)]{
Returns a keymap suitable for frame-level handling of events to
redirect page-up, @|etc| to the browser canvas.
}
This method may be killed (if the user clicks the ``stop'' button).
}
@defmethod[(get-hyper-keymap) (is-a?/c keymap%)]{
Returns a keymap suitable for frame-level handling of events to
redirect page-up, @|etc| to the browser canvas.
}
}
@ -264,8 +261,8 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a
@defclass[hyper-text% (hyper-text-mixin text:keymap%) ()]{
Extends the @scheme[text:keymap%] class to support standard
key bindings in the browser window.
Extends the @scheme[text:keymap%] class to support standard key
bindings in the browser window.
}
@ -273,135 +270,130 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a
@defmixin[hyper-canvas-mixin (editor-canvas%) ()]{
A @scheme[hyper-can-mixin]-extended canvas's parent should be
an instance of a class derived with
@scheme[hyper-panel-mixin].
A @scheme[hyper-can-mixin]-extended canvas's parent should be an
instance of a class derived with @scheme[hyper-panel-mixin].
@defconstructor/auto-super[()]{
}
@defconstructor/auto-super[()]{
}
@defmethod[(get-editor%) (subclass?/c text%)]{
@defmethod[(get-editor%) (subclass?/c text%)]{
Returns the class used to implement the editor in the browser
window. It should be derived from @scheme[hyper-text%] and
should pass on the initialization arguments to
@scheme[hyper-text%].
Returns the class used to implement the editor in the browser
window. It should be derived from @scheme[hyper-text%] and should
pass on the initialization arguments to @scheme[hyper-text%].
The dynamic extent of the initialization of this
editor is called on a thread that may be killed (via a
custodian shutdown). In that case, the editor in the browser's
editor-canvas may not be an instance of this class.
}
The dynamic extent of the initialization of this editor is called on
a thread that may be killed (via a custodian shutdown). In that
case, the editor in the browser's editor-canvas may not be an
instance of this class.
}
@defmethod[(current-page) any/c]{
Returns a representation of the currently displayed page, which
includes a particular editor and a visible range within the
editor.
}
@defmethod[(current-page) any/c]{
Returns a representation of the currently displayed page, which
includes a particular editor and a visible range within the editor.
}
@defmethod[(goto-url [url (or/c url? string?)]
[relative-to-url (or/c url? string? false/c)]
[progress-proc (boolean? . -> . any) void]
[post-data (or/c bytes? false/c) #f])
void?]{
Changes to the given url, loading it by calling the @scheme[make-editor]
method. If @scheme[relative-to-url] is not @scheme[#f], it must be
a URL for resolving @scheme[url] as a relative URL.
@scheme[url] may also be a port, in which case,
@scheme[relative-to-url] must be @scheme[#f].
@defmethod[(goto-url [url (or/c url? string?)]
[relative-to-url (or/c url? string? false/c)]
[progress-proc (boolean? . -> . any) void]
[post-data (or/c bytes? false/c) #f])
void?]{
Changes to the given url, loading it by calling the
@scheme[make-editor] method. If @scheme[relative-to-url] is not
@scheme[#f], it must be a URL for resolving @scheme[url] as a
relative URL. @scheme[url] may also be a port, in which case,
@scheme[relative-to-url] must be @scheme[#f].
The @scheme[progress-proc] procedure is called with a boolean at the
point where the URL has been resolved and enough progress has
been made to dismiss any message that the URL is being
resolved. The procedure is called with @scheme[#t] if the URL will be
loaded into a browser window, @scheme[#f] otherwise (e.g., the user will
save the URL content to a file).
The @scheme[progress-proc] procedure is called with a boolean at the
point where the URL has been resolved and enough progress has been
made to dismiss any message that the URL is being resolved. The
procedure is called with @scheme[#t] if the URL will be loaded into
a browser window, @scheme[#f] otherwise (e.g., the user will save
the URL content to a file).
If @scheme[post-data-bytes] is a byte string instead of false, the URL
GET is changed to a POST with the given data.
}
If @scheme[post-data-bytes] is a byte string instead of false, the
URL GET is changed to a POST with the given data.
}
@defmethod[(set-page [page any/c] [notify? any/c]) void?]{
Changes to the given page. If @scheme[notify?] is not @scheme[#f],
the canvas's parent is notified about the change by calling its
@scheme[leaving-page] method.
}
@defmethod[(set-page [page any/c] [notify? any/c]) void?]{
Changes to the given page. If @scheme[notify?] is not @scheme[#f],
the canvas's parent is notified about the change by calling its
@scheme[leaving-page] method.
}
@defmethod[(after-set-page) void?]{
Called during @scheme[set-page]. Defaultly does nothing.
}
@defmethod[(after-set-page) void?]{
Called during @scheme[set-page]. Defaultly does nothing.
}
}
@; ----------------------------------------------------------------------
@defmixin[hyper-panel-mixin (area-container<%>) ()]{
@defconstructor/auto-super[([info-line? any/c])]{
Creates controls and a hyper text canvas. The
controls permit a user to move back and forth in the hypertext
history.
The @scheme[info-line?] argument indicates whether the browser
should contain a line to display special @(litchar "DOCNOTE")
tags in a page. Such tags are used primarily by the PLT
documentation.}
@defmethod[(make-canvas [container (is-a?/c area-container<%>)]) void?]{
Creates the panel's hypertext canvas, an instance of a class
derived using @scheme[hyper-canvas-mixin]. This
method is called during initialization.
}
@defconstructor/auto-super[([info-line? any/c])]{
Creates controls and a hyper text canvas. The controls permit a
user to move back and forth in the hypertext history.
@defmethod[(get-canvas%) (subclass?/c editor-canvas%)]{
Returns the class instantiated by make-canvas. It must be derived from
@scheme[hyper-canvas-mixin].
}
The @scheme[info-line?] argument indicates whether the browser
should contain a line to display special @litchar{DOCNOTE} tags in a
page. Such tags are used primarily by the PLT documentation.
}
@defmethod[(make-control-bar-panel [container (is-a?/c area-container<%>)])
any/c]{
Creates the panel's sub-container for the control bar containing
the navigation buttons. If @scheme[#f] is returned, the panel will
have no control bar. The default method instantiates
@scheme[horizontal-panel%].
}
@defmethod[(make-canvas [container (is-a?/c area-container<%>)]) void?]{
Creates the panel's hypertext canvas, an instance of a class derived
using @scheme[hyper-canvas-mixin]. This method is called during
initialization.
}
@defmethod[(rewind) void?]{
Goes back one page, if possible.
}
@defmethod[(get-canvas%) (subclass?/c editor-canvas%)]{
Returns the class instantiated by make-canvas. It must be derived
from @scheme[hyper-canvas-mixin].
}
@defmethod[(forward) void?]{
Goes forward one page, if possible.
}
@defmethod[(make-control-bar-panel [container (is-a?/c area-container<%>)])
any/c]{
Creates the panel's sub-container for the control bar containing the
navigation buttons. If @scheme[#f] is returned, the panel will have
no control bar. The default method instantiates
@scheme[horizontal-panel%].
}
@defmethod[(get-canvas) (is-a?/c editor-canvas%)]{
Gets the hypertext canvas.
}
@defmethod[(rewind) void?]{
Goes back one page, if possible.
}
@defmethod[(on-navigate) void?]{
Callback that is invoked any time the displayed hypertext page
changes (either by clicking on a link in the canvas or by
@scheme[rewind] or @scheme[forward] calls).
}
@defmethod[(forward) void?]{
Goes forward one page, if possible.
}
@defmethod[(leaving-page [page any/c] [new-page any/c])
any]{
This method is called by the hypertext canvas to notify the
panel that the hypertext page changed. The @scheme[page] is @scheme[#f]
if @scheme[new-page] is the first page for the canvas. See also
@scheme[page->editor].
}
@defmethod[(get-canvas) (is-a?/c editor-canvas%)]{
Gets the hypertext canvas.
}
@defmethod[(filter-notes [notes (listof string?)])
(listof string?)]{
Given the notes from a page as a list of strings (where
each string is a note), returns a single string to print
above the page.
}
@defmethod[(on-navigate) void?]{
Callback that is invoked any time the displayed hypertext page
changes (either by clicking on a link in the canvas or by
@scheme[rewind] or @scheme[forward] calls).
}
@defmethod[(reload) void?]{
Reloads the currently visible page by calling the @scheme[reload]
method of the currently displayed hyper-text.
}
@defmethod[(leaving-page [page any/c] [new-page any/c])
any]{
This method is called by the hypertext canvas to notify the panel
that the hypertext page changed. The @scheme[page] is @scheme[#f]
if @scheme[new-page] is the first page for the canvas. See also
@scheme[page->editor].
}
@defmethod[(filter-notes [notes (listof string?)])
(listof string?)]{
Given the notes from a page as a list of strings (where each string
is a note), returns a single string to print above the page.
}
@defmethod[(reload) void?]{
Reloads the currently visible page by calling the @scheme[reload]
method of the currently displayed hyper-text.
}
}
@; ----------------------------------------------------------------------
@ -411,46 +403,43 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a
@; ----------------------------------------------------------------------
@defproc[(editor->page [editor (is-a?/c text%)]) any/c]{
Creates a page record for the given editor,
suitable for use with the @scheme[set-page] method of
@scheme[hyper-canvas-mixin].
Creates a page record for the given editor, suitable for use with the
@scheme[set-page] method of @scheme[hyper-canvas-mixin].
}
@defproc[(page->editor [page any/c]) (is-a?/c text%)]{
Extracts the editor from a page record.
Extracts the editor from a page record.
}
@defparam[bullet-size n exact-nonnegative-integer?]{
Parameter controlling the point size of a
bullet.
Parameter controlling the point size of a bullet.
}
@defclass[image-map-snip% snip% ()]{
Instances of this class behave like @scheme[image-snip%] objects,
except they have a @(litchar "<map> ... </map>") associated with them and
when clicking on them (in the map) they will cause their
init arg text to follow the corresponding link.
Instances of this class behave like @scheme[image-snip%] objects,
except they have a @litchar{<map> ... </map>} associated with them and
when clicking on them (in the map) they will cause their init arg text
to follow the corresponding link.
@defconstructor[([html-text (is-a?/c html-text<%>)])]{
}
@defconstructor[([html-text (is-a?/c html-text<%>)])]{
}
@defmethod[(set-key [key string?]) void?]{
Sets the key for the image map (eg, "#key").
}
@defmethod[(set-key [key string?]) void?]{
Sets the key for the image map (eg, @scheme["#key"]).
}
@defmethod[(get-key) string?]{
Returns the current key.
}
@defmethod[(get-key) string?]{
Returns the current key.
}
@defmethod[(add-area [shape string?]
[region (listof number?)]
[href string?])
void?]{
Registers the shape named by @scheme[shape] whose
coordinates are specified by @scheme[region] to go to
@scheme[href] when that region of the image
is clicked on.
}
@defmethod[(add-area [shape string?]
[region (listof number?)]
[href string?])
void?]{
Registers the shape named by @scheme[shape] whose coordinates are
specified by @scheme[region] to go to @scheme[href] when that region
of the image is clicked on.
}
}
@; ----------------------------------------------------------------------
@ -460,9 +449,9 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a
@defmodule[browser/browser-unit]
@defthing[browser@ unit?]{
Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports
@scheme[browser^].}
Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports
@scheme[browser^].
}
@; ----------------------------------------------------------------------
@ -471,9 +460,8 @@ Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports
@defmodule[browser/browser-sig]
@defsignature[browser^ ()]{
Includes all of the bindings of the @schememodname[browser]
library.}
Includes all of the bindings of the @schememodname[browser] library.
}
@; ----------------------------------------------------------------------
@ -483,75 +471,73 @@ library.}
@definterface[html-text<%> (text%)]{
@defmethod[(get-url) (or/c url? string? false/c)]{
Returns a base URL used for building
relative URLs, or @scheme[#f] if no base is available.
}
@defmethod[(get-url) (or/c url? string? false/c)]{
Returns a base URL used for building relative URLs, or @scheme[#f]
if no base is available.
}
@defmethod[(set-title [str string?]) void?]{
Registers the title @scheme[str]
for the rendered page.
}
@defmethod[(set-title [str string?]) void?]{
Registers the title @scheme[str] for the rendered page.
}
@defmethod[(add-link [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[url (or/c url? string?)])
void?]{
Registers a hyperlink for the given region in rendered page.
}
@defmethod[(add-link [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[url (or/c url? string?)])
void?]{
Registers a hyperlink for the given region in rendered page.
}
@defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{
Installs a tag.
}
@defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{
Installs a tag.
}
@defmethod[(make-link-style [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?])
void?]{
Changes the style for the given range to the link style.
}
@defmethod[(make-link-style [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?])
void?]{
Changes the style for the given range to the link style.
}
@defmethod[(add-scheme-callback [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[scheme-expr string?])
void?]{
Installs a Scheme evaluation hyperlink.
}
@defmethod[(add-scheme-callback [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[scheme-expr string?])
void?]{
Installs a Scheme evaluation hyperlink.
}
@defmethod[(add-thunk-callback [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[thunk (-> any)])
void?]{
Installs a thunk-based hyperlink.
}
@defmethod[(add-thunk-callback [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[thunk (-> any)])
void?]{
Installs a thunk-based hyperlink.
}
@defmethod[(post-url [url (or/c string? url?)]
[post-data-bytes (or/c bytes? false/c) #f]) void?]{
Follows the link, optionally with the given post data.
}
@defmethod[(post-url [url (or/c string? url?)]
[post-data-bytes (or/c bytes? false/c) #f]) void?]{
Follows the link, optionally with the given post data.
}
}
@defmixin[html-text-mixin (text%) ()]{
Extends the given @scheme[text%] class with implementations of the
@scheme[html-text<%>] methods. Hyperlinks are attached to clickbacks
that use @net-send-url from @schememodname[net/sendurl].
Extends the given @scheme[text%] class with implementations of the
@scheme[html-text<%>] methods. Hyperlinks are attached to clickbacks
that use @net-send-url from @schememodname[net/sendurl].
}
@defproc[(render-html-to-text [in input-port?]
@defproc[(render-html-to-text [in input-port?]
[dest (is-a? html-text<%>)]
[load-img? any/c]
[load-img? any/c]
[eval-mz? any/c])
void?]{
Reads HTML from @scheme[in] and renders it to @scheme[dest]. If
@scheme[load-img?] is @scheme[#f], then images are rendered as Xed-out
boxes. If @scheme[eval-mz?] is @scheme[#f], then @litchar{MZSCHEME}
hyperlink expressions and comments are not evaluated.
Reads HTML from @scheme[in] and renders it to @scheme[dest].
If @scheme[load-img?] is @scheme[#f], then images are rendered
as Xed-out boxes. If @scheme[eval-mz?] is @scheme[#f], then
@litchar{MZSCHEME} hyperlink expressions and comments are not
evaluated.
Uses the style named @scheme["Html Standard"] in the editor's
style-list (if it exists) for all of the inserted text's
default style.}
Uses the style named @scheme["Html Standard"] in the editor's
style-list (if it exists) for all of the inserted text's default
style.
}
@; ----------------------------------------------------------------------
@ -560,32 +546,33 @@ library.}
@defmodule[browser/external]
@defproc[(send-url [str null] [separate-window? void #t]) null]{
Like @net-send-url from @scheme[net/sendurl] , but under Unix,
the user is prompted for a browser to use if none is recorded
in the preferences file.
Like @net-send-url from @scheme[net/sendurl], but under Unix, the user
is prompted for a browser to use if none is recorded in the
preferences file.
}
@defproc[(browser-preference? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a valid browser preference.
Returns @scheme[#t] if @scheme[v] is a valid browser preference.
}
@defproc[(update-browser-preference [url (or/c string? false/c)]) void?]{
Under Unix, prompts the user for a browser preference and records
the user choice as a framework preference (even if one is already
recorded). If @scheme[url] is not @scheme[#f], it is used in the
dialog to explain which URL is to be opened; if it is @scheme[#f],
the @scheme['internal] will be one of the options for the user.
Under Unix, prompts the user for a browser preference and records the
user choice as a framework preference (even if one is already
recorded). If @scheme[url] is not @scheme[#f], it is used in the
dialog to explain which URL is to be opened; if it is @scheme[#f], the
@scheme['internal] will be one of the options for the user.
}
@defproc[(install-help-browser-preference-panel) void?]{
Installs a framework preference panel for ``Browser'' options.
Installs a framework preference panel for ``Browser'' options.
}
@defproc[(add-to-browser-prefs-panel [proc ((is-a?/c panel%) . -> . any)]) void?]{
The @scheme[proc] is called when the ``Browser'' panel is constructed for
preferences. The supplied argument is the panel, so @scheme[proc] can add
additional option controls. If the panel is already created, @scheme[proc]
is called immediately.
@defproc[(add-to-browser-prefs-panel [proc ((is-a?/c panel%) . -> . any)])
void?]{
The @scheme[proc] is called when the ``Browser'' panel is constructed
for preferences. The supplied argument is the panel, so @scheme[proc]
can add additional option controls. If the panel is already created,
@scheme[proc] is called immediately.
}
@; ----------------------------------------------------------------------
@ -595,7 +582,6 @@ library.}
@defmodule[browser/tool]
@defthing[tool@ unit?]{
A unit that implements a DrScheme tool to add the ``Browser''
preference panel.
}

8
collects/compiler/decompile.ss
View File

@ -321,13 +321,15 @@
list list* vector vector-immutable box))]
[(3) (memq (car a) '(eq? = <= < >= >
bitwise-bit-set? char=?
+ - * / quotient remainder min max bitwise-and bitwise-ior
+ - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor
arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons
list list* vector vector-immutable))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set!
list list* vector vector-immutable))]
[else (memq (car a) '(list list* vector vector-immutable))]))
list list* vector vector-immutable
+ - * / min max bitwise-and bitwise-ior bitwise-xor))]
[else (memq (car a) '(list list* vector vector-immutable
+ - * / min max bitwise-and bitwise-ior bitwise-xor))]))
(cons '#%in a)
a))

2
collects/deinprogramm/DMdA-assignments.ss
View File

@ -19,5 +19,5 @@
procedures
(all-from-except assignments: deinprogramm/DMdA procedures
quote
symbol?))
symbol? string->symbol symbol->string))

2
collects/deinprogramm/DMdA-beginner.ss
View File

@ -18,5 +18,5 @@
quote
make-pair pair? first rest
length map for-each reverse append list list-ref fold
symbol?
symbol? string->symbol symbol->string
apply))

2
collects/deinprogramm/DMdA-vanilla.ss
View File

@ -17,5 +17,5 @@
quote eq? equal?
set!
define-record-procedures-2
symbol?
symbol? string->symbol symbol->string
apply))

4
collects/deinprogramm/DMdA.ss
View File

@ -316,7 +316,9 @@
(symbol? (%a -> boolean)
"feststellen, ob ein Wert ein Symbol ist")
(symbol->string (symbol -> string)
"Symbol in Zeichenkette umwandeln"))
"Symbol in Zeichenkette umwandeln")
(string->symbol (string -> symbol)
"Zeichenkette in Symbol umwandeln"))
("Verschiedenes"
(equal? (%a %b -> boolean)

2
collects/deinprogramm/scribblings/DMdA-beginner.scrbl
View File

@ -341,7 +341,7 @@ Dieser Testfall überprüft experimentell, ob die @tech{Eigenschaft}
@emph{Wichtig:} @scheme[check-property] funktioniert nur für
Eigenschaften, bei denen aus den Verträgen sinnvoll Werte generiert
werden können. Dies ist für die meisten eingebauten Verträge der
Fall, aber nicht für Verträge, die mit @scheme[predicate],
Fall, aber nicht für Vertragsvariablen und Verträge, die mit @scheme[predicate],
@scheme[property] oder @scheme[define-record-procedures] definiert
wurden. In diesen Fällen erzeugt @scheme[check-property] eine Fehlermeldung.
}

6
collects/deinprogramm/scribblings/image.scrbl
View File

@ -88,20 +88,20 @@ Die folgenden Prozeduren erzeugen Bilder mit einfachen geometrischen Formen:
@defthing[ellipse (natural natural mode image-color -> image)]{
Der Aufruf @scheme[(ellipse w h m c)]
erzeugt eine Ellipse mit Breite @scheme[w] und Höhe @scheme[h], gefüllt mit Modus
@scheme[m] uns in Farbe @scheme[c].}
@scheme[m] und in Farbe @scheme[c].}
@defthing[triangle (integer mode image-color -> image)]{
Der Aufruf @scheme[(triangle s m c)]
erzeugt ein nach oben zeigendes gleichseitiges Dreieck, wobei
@scheme[s] die Seitenlänge angibt, gefüllt mit Modus
@scheme[m] uns in Farbe @scheme[c].}
@scheme[m] und in Farbe @scheme[c].}
@defthing[line (natural natural number number number number image-color -> image)]{
Der Aufruf @scheme[(line w h sx sy ex ey c)]
erzeugt ein Bild mit einer farbigen Strecke, wobei @scheme[w] die Breite und @scheme[h] die Höhe des Bilds,
sowie @scheme[sx] die X- und @scheme[sx] die Y-Koordinate des Anfangspunkts und
@scheme[ex] die X- und @scheme[ey] die Y-Koordinate des Endpunkts angeben, gefüllt mit Modus
@scheme[m] uns in Farbe @scheme[c].}
@scheme[m] und in Farbe @scheme[c].}
@defthing[text (string natural image-color -> image)]{
Der Aufruf @scheme[(text s f c)]

12
collects/drscheme/private/frame.ss
View File

@ -27,6 +27,18 @@
(define basics-mixin
(mixin (frame:standard-menus<%>) (basics<%>)
(define/override (on-subwindow-char receiver event)
(let ([user-key? (send (keymap:get-user)
handle-key-event
(if (is-a? receiver editor-canvas%)
(send receiver get-editor)
receiver)
event)])
;; (printf "user-key? ~s\n" user-key?) returns #t for key release events -- is this a problem? (we'll find out!)
(or user-key?
(super on-subwindow-char receiver event))))
(inherit get-edit-target-window get-edit-target-object get-menu-bar)
(define/private (get-menu-bindings)
(let ([name-ht (make-hasheq)])

4
collects/drscheme/private/tools.ss
View File

@ -316,6 +316,8 @@
(let loop ([sexp full-sexp])
(match sexp
[`((#%module-begin ,body ...))
(loop body)]
[`((provide/doc (,x ,name ,ctc ,other ...) ...) ,rest ...)
#`(let #,(map (λ (name ctc)
(with-syntax ([name (datum->syntax #'tool-name name)]
@ -331,7 +333,7 @@
[`(,a . ,b)
(loop b)]
[`()
(error 'tcl.ss "did not find provide/doc" full-sexp)])))]))
(error 'tcl.ss "did not find provide/doc: ~a" full-sexp)])))]))
;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
;; invokes the tools and returns the two phase thunks.

2
collects/eopl/eopl.scrbl
View File

@ -4,7 +4,7 @@
scheme/list
(for-label eopl/eopl
scheme/contract
(only-in scheme printf pretty-print)))
(only-in scheme printf pretty-print delay force)))
@(define-syntax-rule (def-mz id)
(begin

3
collects/framework/gui-utils.ss
View File

@ -1,5 +1,4 @@
#reader scribble/reader
#lang scheme/base
#lang at-exp scheme/base
(require string-constants scheme/gui/base
scheme/contract scheme/class)

70
collects/framework/private/bday.ss
View File

@ -1,40 +1,32 @@
#lang scheme/base
(require "decode.ss")
(decode
\5d8f4
\10ec22010
\45aff297b02
\0 \69d544
\5da867
\299da9
\360a3
\5404db
\cbde0b
\4b571f
\7798f6
\13ecaf
\2b5f75
\0cf30bc
\7a62b8d0
\194bcdfb
\023787789
\f02\5b091a
\8ab \8eb3d4
\3a9 \02e040
\3ac \307a74
\ca8 \495944
\6e0 \74fd1
\9ce5 \d88e21
\b04 \f66c25
\a97f \b8d27a
\813 \be13c6
\0d3e \dd50a2
\86d3 \3f5ede
\174a \3235ad9
\ecb40 \2aecb1
\ad56 \76292fb
\6aeb0 \39ae75f
\8f335 \ea955
\e7e \2c7
#lang s-exp framework/private/decode
||\6||\8||\7||\4||\3||\d||\e||\f||\c||\0||\1)
XY9BD
sIgEEWv
8pfMgqRV
E3Whn
qXtT
GOjg
AE08
fYWp
62Nu
897D
PMxjx
heAwtc
7G3Lzfs
CN4 d0m
4K0G giGp
R+8w JgC4
MA0w rvkk
XCTR 5GkC
56T Peux
e8Yo PtsJ
E5X7 jWeY
E74T 1gWf
ryiR 4OjH
y/tK Waem
1XMZ aIU9
ttXK LuXV
1hU2 x7WO
f75G vdLLj
9Xuc CD6A
\\\\ A==

56
collects/framework/private/decode.ss
View File

@ -1,43 +1,19 @@
#lang scheme/base
(require (for-syntax mzlib/inflate
scheme/base))
(require (for-syntax scheme/base file/gunzip net/base64))
(provide (except-out (all-from-out scheme/base) #%module-begin)
(rename-out [module-begin #%module-begin]))
(provide decode)
(define-syntax (decode stx)
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ arg ...)
(andmap identifier? (syntax->list (syntax (arg ...))))
(let ()
(define (decode-sexp str)
(let* ([loc
(let loop ([chars (string->list str)])
(cond
[(null? chars) '()]
[(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")]
[else (let ([fst (to-digit (car chars))]
[snd (to-digit (cadr chars))])
(cons
(+ (* fst 16) snd)
(loop (cddr chars))))]))])
(let-values ([(p-in p-out) (make-pipe)])
(inflate (open-input-bytes (apply bytes loc)) p-out)
(read p-in))))
(define (to-digit char)
(cond
[(char<=? #\0 char #\9)
(- (char->integer char)
(char->integer #\0))]
[(char<=? #\a char #\f)
(+ 10 (- (char->integer char)
(char->integer #\a)))]))
(define decoded
(decode-sexp
(apply
string-append
(map (λ (x) (symbol->string (syntax-e x)))
(syntax->list (syntax (arg ...)))))))
(datum->syntax stx decoded stx))]))
[(_ x ...)
(andmap (lambda (x) (or identifier? (integer? (syntax-e x))))
(syntax->list #'(x ...)))
(let* ([data (format "~a" (syntax->datum #'(x ...)))]
[data (substring data 1 (sub1 (string-length data)))]
[data (string->bytes/utf-8 data)]
[in (open-input-bytes (base64-decode data))]
[out (open-output-string)]
[out (begin (inflate in out) (get-output-string out))]
[exprs (read (open-input-string (string-append "(" out ")")))]
[exprs (datum->syntax stx exprs stx)])
#`(#%module-begin #,@exprs))]))

100
collects/framework/private/encode.ss
View File

@ -1,67 +1,43 @@
#lang scheme/base
(require mzlib/deflate
mzlib/match
mzlib/pretty)
(require (for-syntax mzlib/inflate
mzlib/string))
(require scheme/cmdline scheme/string scheme/match scheme/pretty
file/gzip file/gunzip net/base64)
(provide encode-sexp
encode-module)
(define (encode-exprs exprs)
(define in
(open-input-string
(string-join (map (lambda (x) (format "~s" x)) exprs) " ")))
(define out (open-output-bytes))
(deflate in out)
(base64-encode (get-output-bytes out)))
(define (encode-module in-filename out-filename)
(call-with-input-file in-filename
(λ (port)
(let ([mod (read port)])
(unless (eof-object? (read port))
(error 'encode-module "found an extra expression"))
(match mod
[`(module ,m mzscheme ,@(bodies ...))
(call-with-output-file out-filename
(λ (oport)
(let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
(fprintf oport "(module ~a mzscheme\n" m)
(fprintf oport " (require framework/private/decode)\n")
(fprintf oport " (decode ~a" (car chopped))
(for-each (lambda (chopped)
(fprintf oport "\n ~a" chopped))
(cdr chopped))
(fprintf oport "))\n")))
'truncate 'text)]
[else (error 'encode-module "cannot parse module")])))))
(define (encode-module)
(define mod (parameterize ([read-accept-reader #t]) (read)))
(when (eof-object? mod) (error 'encode-module "missing module"))
(match mod
[(list 'module m 'scheme/base (list '#%module-begin exprs ...))
(write-bytes #"#lang s-exp framework/private/decode\n")
(write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))]
[else (error 'encode-module "cannot parse module, must use scheme/base")]))
(define (chop-up sym)
(let ([chopping-point 50])
(let loop ([str (symbol->string sym)])
(cond
[(<= (string-length str) chopping-point)
(list (string->symbol str))]
[else
(cons (string->symbol (substring str 0 chopping-point))
(loop (substring str chopping-point (string-length str))))]))))
(define (decode-module)
(define mod (parameterize ([read-accept-reader #t]) (read)))
(when (eof-object? mod) (error 'encode-module "missing module"))
(match mod
[(list 'module m 'framework/private/decode
(list '#%module-begin exprs ...))
(write-bytes #"#lang scheme/base\n")
(let* ([data (format "~a" exprs)]
[data (substring data 1 (sub1 (string-length data)))]
[data (string->bytes/utf-8 data)]
[in (open-input-bytes (base64-decode data))]
[out (open-output-string)]
[out (begin (inflate in out) (get-output-string out))]
[exprs (read (open-input-string (string-append "(" out ")")))])
(for ([expr (in-list exprs)])
(pretty-print expr)))]
[else (error 'decode-module "cannot parse module, must use scheme/base")]))
(define (encode-sexp sexp)
(define (str->sym string)
(string->symbol
(apply
string-append
(map
(λ (x)
(to-hex x))
(bytes->list string)))))
(define (to-hex n)
(let ([digit->hex
(λ (d)
(cond
[(<= d 9) d]
[else (integer->char (+ d -10 (char->integer #\a)))]))])
(cond
[(< n 16) (format "0~a" (digit->hex n))]
[else (format "~a~a"
(digit->hex (quotient n 16))
(digit->hex (modulo n 16)))])))
(let ([in (open-input-string (format "~s" sexp))]
[out (open-output-bytes)])
(deflate in out)
(str->sym (get-output-bytes out))))
(command-line #:once-any
["-e" "encode" (encode-module) (exit)]
["-d" "decode" (decode-module) (exit)])
(printf "Use `-h' for help\n")

2
collects/honu/private/debug.ss
View File

@ -4,7 +4,7 @@
(provide debug)
(define-for-syntax verbose? #f)
(define-for-syntax verbose? #t)
(define-syntax (debug stx)
(if verbose?
(syntax-case stx ()

1
collects/honu/private/honu.ss
View File

@ -126,6 +126,7 @@
(let ([v (syntax-local-value (stx-car first) (lambda () #f))])
(and (honu-transformer? v) v))]
[else #f]))))
;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
(or (bound-transformer stx)
(special-transformer stx)))

330
collects/honu/private/macro.ss
View File

@ -1,8 +1,13 @@
#lang scheme/base
(require "honu.ss"
(for-syntax "debug.ss")
(for-syntax scheme/base))
(for-syntax "debug.ss"
"contexts.ss"
scheme/base
syntax/parse
syntax/stx
scheme/pretty
scheme/trace))
(provide honu-macro)
@ -21,6 +26,9 @@
(loop out #'(rest1 rest ...))]
[(foo) out])))
(define-syntax (semicolon stx)
stx)
(define-for-syntax (extract-patterns pattern)
(let loop ([out '()]
[in pattern])
@ -36,6 +44,29 @@
#'(rest1 rest ...)))]
[(foo) (reverse (cons #'foo out))])))
#|
(define-for-syntax (convert stx)
(syntax-case stx (...)
[(_ x ...)
|#
(define-for-syntax (fix-template stx) stx)
#|
(define-for-syntax (fix-template stx)
[(any \;
(... ...) rest1 rest ...)
(loop (cons #'(semicolon any (... ..)))
#'(rest1 rest ...))]
[((any1 any ...) rest1 rest ...)
(loop (loop out #'(any1 any ...))
#'(rest1 rest ...))]
|#
;; x = 1 + y; ...
#;
(define-honu-syntax honu-macro
(lambda (stx ctx)
(debug "Original macro: ~a\n" (syntax->datum stx))
@ -47,7 +78,10 @@
(with-syntax ([(conventions ...)
(extract-conventions #'(pattern ...))]
[(raw-patterns ...)
(extract-patterns #'(pattern ...))])
(extract-patterns #'(pattern ...))]
[(fixed-template ...)
(fix-template #'(template ...))])
(debug "new template ~a\n" (syntax->datum #'(fixed-template ...)))
(values
(syntax/loc
stx
@ -80,7 +114,7 @@
[(name pattern ...)
#'(honu-unparsed-block
#f obj 'obj #f ctx
template ...)]))
fixed-template ...)]))
(let ([result (syntax-case stx
#;
@ -92,7 +126,7 @@
[(name raw-patterns ...)
#'(honu-unparsed-block
#f obj 'obj #f ctx
template ...)]
fixed-template ...)]
[else 'fail-boat])])
(debug "result was ~a\n" result))
(syntax-case stx (honu-literal ...)
@ -100,7 +134,7 @@
(values
#'(honu-unparsed-block
#f obj 'obj #f ctx
template ...)
fixed-template ...)
#'rrest)])))
#;
(define-honu-syntax name
@ -115,7 +149,289 @@
(values
#'(honu-unparsed-block
#f obj 'obj #f ctx
template ...)
fixed-template ...)
#'rrest)])))))
#'rest))])
))
(define-for-syntax (delimiter? x)
(or (free-identifier=? x #'\;)))
(define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this"))
;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap"))
;; just a phase 0 identifier
(define wrapped #f)
(define unwrap #f)
(define-for-syntax (pull stx)
(define (reverse-syntax stx)
(with-syntax ([(x ...) (reverse (syntax->list stx))])
#'(x ...)))
(define-syntax-class stop-class
(pattern x:id #:when (or (free-identifier=? #'x #'(... ...))
(free-identifier=? #'x #'\;))))
(define (do-ellipses stx)
(let loop ([ellipses '()]
[body '()]
[stx stx])
(cond
[(null? stx) (values (with-syntax ([(ellipses ...) ellipses]
[(body ...) body])
#'(ellipses ... body ...))
stx)]
[(and (identifier? (car stx))
(free-identifier=? (car stx) #'(... ...)))
(loop (cons #'(... ...) ellipses) body (cdr stx))]
[(and (identifier? (car stx))
(free-identifier=? (car stx) #'\;))
;; (printf "Found a ; in ~a\n" (syntax->datum stx))
(with-syntax ([all (cdr stx)])
;; (printf "Found a ; -- ~a\n" (syntax->datum #'all))
(syntax-parse #'all
[((~and x (~not _:stop-class)) ... stop:stop-class y ...)
(with-syntax ([(ellipses ...) ellipses]
[(x* ...) (reverse-syntax #'(x ...))])
(values #'(ellipses ... (wrapped x* ... \;) unwrap)
#'(stop y ...)))]
[else (with-syntax ([(f ...) (reverse-syntax #'all)]
[(ellipses ...) ellipses])
(values #'(ellipses ... (wrapped f ... \;) unwrap)
#'()))]))])))
(let loop ([all '()]
[stx (reverse (syntax->list stx))])
(if (null? stx)
(with-syntax ([x all])
#'x)
(let ([head (car stx)]
[tail (cdr stx)])
(cond
[(and (identifier? head)
(free-identifier=? head #'(... ...)))
(let-values ([(wrapped rest) (do-ellipses (cons head tail))])
(loop (cons (reverse-syntax wrapped) all) (syntax->list rest)))]
[else (loop (cons head all) tail)])))))
;; rename this to wrap
#;
(define-for-syntax (pull stx)
(define (reverse-syntax stx)
(with-syntax ([(x ...) (reverse (syntax->list stx))])
#'(x ...)))
(define-syntax-class delimiter-class
(pattern x:id #:when (delimiter? #'x)))
(define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define-syntax-class not-ellipses-class
(pattern x:id #:when (not (free-identifier=? #'x #'(... ...)))))
;; use this if you are defining your own ellipses identifier
#;
(define-syntax-class ellipses-class
#:literals (...)
(pattern my-ellipses))
(if (not (stx-pair? stx))
stx
(let ([stx (reverse (syntax->list stx))])
;; (debug-parse stx (ellipses1:ellipses-class ellipses:ellipses-class ... x ...))
;; (printf "stx is ~a\n" stx)
;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
(syntax-parse stx
[(before:not-ellipses-class ... ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...)
(with-syntax ([(x* ...) (reverse-syntax (pull #'(delimiter x ...)))])
(reverse-syntax
(with-syntax ([wrapped #'wrapped]
[original
(with-syntax ([(ellipses* ...) (map (lambda (_)
#'((... ...) (... ...)))
(syntax->list #'(ellipses1 ellipses ...)))]
[(x-new ...) (generate-temporaries #'(delimiter x ...))])
(reverse-syntax #'(before ... ellipses* ... x-new ...)))]
#;
[original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
#'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
[(ellipses1:ellipses-class ellipses:ellipses-class ... x ...)
(with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))])
(reverse-syntax
(with-syntax ([wrapped #'wrapped]
[original
(with-syntax ([(ellipses* ...) (map (lambda (_)
#'((... ...) (... ...)))
(syntax->list #'(ellipses1 ellipses ...)))]
[(x-new ...) (generate-temporaries #'(x ...))])
(reverse-syntax #'(ellipses* ... x-new ...)))]
#;
[original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
#'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
[(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))])
(reverse-syntax #'(x* ...)))]))))
;; (begin-for-syntax (trace pull))
(define-for-syntax (unpull stx)
(define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define-syntax-class delimiter-class
(pattern x:id #:when (delimiter? #'x)))
;; (printf "unpull ~a\n" (syntax->datum stx))
(syntax-parse stx
#:literals (wrapped unwrap)
[((~and z (~not (unwrap _ ...))) ... (unwrap (wrapped x ... delimiter:delimiter-class) ...) rest ...)
(with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))]
[(rest* ...) (unpull #'(rest ...))])
#'(z ... x1 ... rest* ...))]
[(unwrap (wrapped x ... delimiter:delimiter-class) ...)
(with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))])
#'(x1 ...))]
[(unwrap (wrapped x ... y) ...)
(with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
(with-syntax ([(x1* ...) (map unpull (syntax->list #'(x1 ...)))]
[(y* ...) (map unpull (syntax->list #'(y ...)))])
#'(x1* ... y* ...)))]
[(unwrap . x) (raise-syntax-error 'unpull "unhandled unwrap ~a" stx)]
[(x ...) (with-syntax ([(x* ...) (map unpull (syntax->list #'(x ...)))])
#'(x* ...))]
[else stx]))
;; rename this to unwrap
#;
(define-syntax (unpull stx)
(define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define (do-it stx)
(syntax-parse stx
#:literals (wrapped)
[((wrapped x ... y) ...)
(with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
#'(x1 ... y ...))]
[((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
(with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
#'(x* ... ellipses1 ellipses ...))]
[(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
#'(x* ...))]
[else stx]))
(syntax-case stx ()
[(_ x ...) (do-it #'(x ...))]))
;; (provide unpull)
#;
(define-honu-syntax unpull
(lambda (stx ctx)
(define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define (do-it stx)
(syntax-parse stx
#:literals (wrapped)
[((wrapped x ... y) ...)
(with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
#'(x1 ... y ...))]
[((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
(with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
#'(x* ... ellipses1 ellipses ...))]
[(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
(printf "x* is ~a\n" #'(x* ...))
#'(x* ...))]
[else stx]))
(syntax-case stx ()
[(_ x ...) (values (do-it #'(x ...))
#'())])))
#;
(define-syntax (test stx)
(syntax-case stx ()
[(_ x ...)
(begin
(pretty-print (syntax->datum (pull #'(x ...))))
(pretty-print (syntax->datum (unpull (pull #'(x ...)))))
#'1)]))
(define-syntax (my-syntax stx)
(syntax-case stx ()
[(_ name pattern template)
(with-syntax ([wrap-it (pull #'template)])
#'(define-syntax (name stx)
(syntax-case stx ()
[pattern #'wrap-it]
[else (raise-syntax-error 'name (format "~a does not match pattern ~a"
(syntax->datum stx)
'pattern))]
)))]))
(define-syntax (test2 stx)
(syntax-case stx ()
[(_ x ...)
(begin
(with-syntax ([pulled (pull #'(x ...))])
#'(unpull pulled)))]))
(define-honu-syntax honu-macro
(lambda (stx ctx)
(syntax-case stx (#%parens #%braces)
[(_ (#%parens honu-literal ...)
(#%braces (#%braces name pattern ...))
(#%braces (#%braces template ...))
. rest)
(with-syntax ([pulled (pull #'(template ...))]
[(pattern* ...) (map (lambda (stx)
(if (and (identifier? stx)
(not (ormap (lambda (f)
(free-identifier=? stx f))
(syntax->list #'(honu-literal ...))))
(not (free-identifier=? stx #'(... ...))))
(with-syntax ([x stx])
#'(~and x (~not (~or honu-literal ...))))
stx))
(syntax->list #'(pattern ...)))]
)
(values
#'(define-honu-syntax name
(lambda (stx ctx)
;; (define-literal-set literals (honu-literal ...))
(syntax-parse stx
;; #:literal-sets (literals)
#:literals (honu-literal ...)
[(name pattern* ... . rrest)
(with-syntax ([(out (... ...)) (unpull #'pulled)])
(define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context"))
(values
;; this is sort of ugly, is there a better way?
(cond
[(type-context? ctx) (X)]
[(type-or-expression-context? ctx) (X)]
[(expression-context? ctx) #'(honu-unparsed-expr out (... ...))]
[(expression-block-context? ctx)
#'(honu-unparsed-begin out (... ...))]
[(block-context? ctx)
#'(honu-unparsed-begin out (... ...))]
[(variable-definition-context? ctx) (X)]
[(constant-definition-context? ctx) (X)]
[(function-definition-context? ctx) (X)]
[(prototype-context? ctx) (X)]
[else #'(honu-unparsed-expr out (... ...))])
#;
#'(honu-unparsed-begin out (... ...))
#'rrest)
#;
#'(honu-unparsed-block
#f obj 'obj #f ctx
out (... ...))
#;
(values
#;
#'(honu-unparsed-expr out (... ...))
#'(honu-unparsed-block
#f obj 'obj #f ctx
out (... ...) rrest)
#;
#'rrest))])))
#'rest))])))
;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...))
;; (guz display (#%parens 1 2 3 4))
;; (local-expand stx 'expression (list #'wrapped))
#|
(begin-for-syntax
(trace pull))
(test display (#%parens x))
(test display (#%parens x ... ...) ...)
|#

2
collects/htdp/image.ss
View File

@ -407,7 +407,7 @@ plt/collects/tests/mzscheme/htdp-image.ss
(cond
[(string=? str "")
(let-values ([(tw th) (get-text-size size "dummyX")])
(rectangle 0 th 'solid 'black))]
(put-pinhole (rectangle 0 th 'solid 'black) 0 0))]
[else
(let ([color (make-color% color-in)])
(let-values ([(tw th) (get-text-size size str)])

23
collects/htdp/show-queen.ss
View File

@ -1 +1,22 @@
(module show-queen mzscheme (require framework/private/decode) (decode ad56db8ee3360cfd15368b05eca6eecc60fbb05834cd1f14e81714b2cd444a65c923cbb9ec43bfbda464d97226b3e8167db2c5cb21451d512c6a3c2a0385c3d751398442ab1a369dc3f6e761d8c4bf4d39891b2d8681e525497a67cfaa4518a4bd54af23a221618b0765107a876765c7a13a38d1217c382caae6231401071a61ce62a0e541a16ea13857b515ae850fcf05e30fea2bc273397b3ef563ad55038532ca4330652bf43f40f2a42c075ffd76c6c65b0745277a5849a25399dc428422ea2a8de6e86582621b6baa5e28e3f3149c3a0b4f4e47f4a0e054ceee0e0fabff94922ac9aae4a4253aca9b1cab462b34be0ae179dd36e55c844ec56a7527fe2e91ed199de372735a78267fc0b3277d630db915bcdf01e997a4d0d1c998e3becc44e440f159c88749d9170589af99056772652d2d6e77f21bcb0f76346d650deea7d40eb457148dac06dab7b2c4222dbaba15b45b38c1156ee0a51aaa4bfc48f2b848242bc119ffba238b98c296fea225a392e20631876d8290cba1e559f0fe47a391c8144189c442efe9643a55ceab1374a7d99deaabe6ff5338c1e59c439409308bb38e61ac8ff0e167851c4e2e4187c51df652558d229d512c0a1d202174a7ef817bc48da84f67dc3681ab4cb1ff766203f3d56aeb0620ac4dad45f317b505ad8ed21f9db86d12c948db3a7121f2375e98a3c66f1060b93d8a6e8d970ee952196cabfab68f5598d4ef449f7ad23b5aeb283e6ecafbcc506bd50f18f9563ca5dc3eb321332d896414fd980c3e3dfdb22c6558962b2ec78c8b5de2dd2ea7dca30c8f8ebae59bcafdaff9ad0832b7ad37e77f884ca9ce428f480c2f8a0bf039ddb5a972e91a976af0d843f13a5acf7ab840b48042deab24ac9cb5b5a425aa3d93e04a1df740809d6d476d33946b6cfae9ce7155832a2530ed3a50e72b3abb870855424a6d9bfe5ecafbd8a710fbb68e2de7d8b7fbd8a707b1651efb36c596736cb98a7d80f76e56cc684bda97f211e23314d5b460b0bb6e586608ea0ee19a235c57084ba34d1419c61e5d65f09211e69eb87df8853a7c32dab255cfb72008bc445e55fce402c150f7745513ee76b09a505e22416870b05aa5d778c1abdd38c80c31ac1f6246cb98d43d66b6956fb497ecf232c42ebd0ebbf434ecb882d1b69ada73946e27e93649f3900f869e30eaac44c53237cdc3cca4fa934a348d65ab97878bb09f8d49c403cedcc1afe5caecba98d4d6d27363584659cef30d3d1a59e1b2296e83d79efa03b620c2fc04f6307f27ac01683bcaf4a3ff098ed67f81bf71b320c7d66846ad9774df8f46a71ca1a01b29488d14360e4f17451399088f2547e7425293dc64cd48f17ee3e4b60c7759d1de546807b94f56907f550f4e7572a55af0ca8e3457c5ea780b9df08d04eeb049cfd6d20f69a98c99cc87b785cbbaac41a26b1874c3981118b5bc3a9936ce448170e47489bf1f79cf356ad8fc0e7ff01e067e6c68e394f7a767ee8012f9010f8b798099481a60784aef85e3269e62a77b3a99ada6f0b7599161cc8a0bc9931afb9f6db89cff00))
#lang s-exp framework/private/decode
rVbbjqQ2EP2VSq9WgnTIzGjzsFql038QKV8QGSja7oDNGNOXfci3p8rGYJieVTbKE7gup8rl
43JlFl9HZRGyVpWw6yzWPw/DLvzt8klctWIYWJ6TpLfmomqEQZpr8ToiahLW2CiN0Fu8KDMO
RWNFh/ChWVTVR8g8DlRCX8RAy0ZhW0N2KUojbA0fMoYf1FeE53x2fOrHslUVZEorB96SrdD9
ANGRkhxc8dsFK2csZJ3oYSUJTnl08xGyoCta1CcnIxTbGF30QmmXpmDVRThyOqEDBed8drfY
rP5jSionq5yTlmgpb3IsqlahdoUPz+u6yucadCoUqzvzd4lsLmgtV5vTwgv5A14c6SujyS3j
/Q5IvySFjg5Gn455IiIHis9CPkvKPstIfEssOJMba2lx38jvLG/MqOvCaDxOqTW0VxSVLAba
tzKagEVX1oJ2C2e4wR2cVENxDR9JHleJZCU4418PZBFS2NNfsGRUUtwh5LCPEHI5tDQL3v+o
WyQuBVDisGiPdDKdyufVGbrz7E71VfP/2Z/gcs4+ygSYxFnH0MYFeP+zQvYnF6H9YoO9VLVF
Ec8oFIUOkBC68/fAPeJG0MczrivPVabYfzuxgflqWmMHIKxd2YrqL+oKrTpJd7LivoskI21t
xZXIXzmhTy1+gwDL7VF0a5y0SJdKY12U92OowqR+J/rUkt7RGkvxcZdvM8O2Vf2AgW/ZU8zt
Mxsy06JIBtGP0eDT0y/LUvplvuJyyDg7RN4dUso9yvBkqVm+qdz/mt+KIHPbenP+TWBKcRHt
iMTwLLsCn9OmTeVL17gWg8MestfRONbDFYIFZHKrkrBybo0hLVHtmQQ36rgNAXamHluToNxC
0493jqvqVTGBadeeOl/RmiMEqBxiavv495JvY5997Ps6tpxj37exzw9iyzT2fYot59hyFbuB
925WyGhP2pf8EeIzZMW0YLBNN8wTBLVBuKUItxXC0mgjRYaxR1tovCaE2RK3979Q+k9CW7bq
+RZ4gZPIq4KfXCAY6p62qPzd9lYTyksgCM0NplXxNV7wSjsOMkH064eYwTIktcVMtvKN9pJc
XoY4xNfhEJ+GA1cw2BZTew7S/STdR2ka8sHM4yedlShbxqZ5mJlUf1KJSjwpvXl5uAjH2ZhE
PODMHfyWr8xui0lpDD03mmWU5Tzf0KORFC4Z4nZ466k/YA3Cz09gmvk7YQ1A21G6H91PcDLu
C/yNuwU5tEY9tu2S7vvR6JQDFHQjBSmRwobh6apoIhP+seToXEhqkrukGSneb5jcluEuKdqb
Ch0g9UkK8q/qwalOrlQLXpmR5qpQHWegE66SwB026tlauiEuldaT+fC2cEmX1Uh09YOuHzM8
o5ZXJ9GGmcgTjpyu4fcj77nEFna/wx+8h4EfG9o45f3pmTugRH7A/WIeYCaSehge0nthuYnH
2PGeTmarKfxtVmQYsuJC8qTG/hfDl/Mf

3
collects/lang/info.ss
View File

@ -8,6 +8,9 @@
(define tool-names (list "How to Design Programs"))
(define tool-urls (list "http://www.htdp.org/"))
(define compile-omit-paths
'("test-error.ss"))
(define textbook-pls
(list (list '("htdp-icon.gif" "icons")
"How to Design Programs"

1
collects/lang/private/TODO
View File

@ -38,4 +38,3 @@ string-ref : String Nat -> Char
NOTE:
substring consumes 2 or 3 arguments

19
collects/lang/private/teachprims.ss
View File

@ -192,8 +192,25 @@ namespace.
(apply append x)))))
(define-teach beginner error
(lambda stuff0
(define-values (f stuff1)
(if (and (cons? stuff0) (symbol? (first stuff0)))
(values (first stuff0) (rest stuff0))
(values false stuff0)))
(define str
(let loop ([stuff stuff1][frmt ""][pieces '()])
(cond
[(empty? stuff) (apply format frmt (reverse pieces))]
[else
(let ([f (first stuff)]
[r (rest stuff)])
(if (string? f)
(loop r (string-append frmt f) pieces)
(loop r (string-append frmt "~e") (cons f pieces))))])))
(if f (error f str) (error str)))
#;
(lambda (str)
(unless (string? str)
(unless (string? str)
(raise
(make-exn:fail:contract
(format "error: expected a string, got ~e and ~e" str)

16
collects/lang/test-error.ss Normal file
View File

@ -0,0 +1,16 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname bar) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(check-error (error) "")
(check-error (error 1) "1")
(check-error (error 'a) "a: ")
(check-error (error 'a "bad input") "a: bad input")
(check-error (error 'a "bad input: " 1) "a: bad input: 1")
(check-error (error 'a "bad input: " 1 " and " "hello") "a: bad input: 1 and hello")
(check-error (error 'a "bad input: " 1 " and " false) "a: bad input: 1 and false")
(check-error (error 'a "uhoh " (list 1 2 3)) "a: uhoh (cons 1 (cons 2 (cons 3 empty)))")
(define-struct err (str))
(check-error (error 'a "bad input: " 1 " and " (make-err "hello"))
"a: bad input: 1 and (make-err \"hello\")")

3
collects/lazy/lazy.scrbl
View File

@ -1,7 +1,8 @@
#lang scribble/doc
@(require (for-label (except-in lazy delay force)
(only-in lazy/force ! !! !list !!list)
scheme/contract))
scheme/contract
(only-in scheme/promise promise?)))
@(define-syntax-rule (deflazy mod def id)
(begin

2
collects/macro-debugger/syntax-browser/text.ss
View File

@ -285,7 +285,7 @@
(send dc set-text-foreground color)
(send dc draw-text "?"
(+ endx dx fw)
(- endy dy fh)))))))])
(- (+ endy dy) fh)))))))])
(add-mouse-drawing from1 from2 draw tack-box)
(add-mouse-drawing to1 to2 draw tack-box))))

20
collects/mrlib/image-core.ss
View File

@ -626,21 +626,23 @@ the mask bitmap and the original bitmap are all together in a single bytes!
[orig-h (send orig-bm get-height)]
[x-scale (bitmap-x-scale bitmap)]
[y-scale (bitmap-y-scale bitmap)]
[scale-w (* x-scale (send orig-bm get-width))]
[scale-h (* y-scale (send orig-bm get-height))]
[scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))]
[scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))]
[new-bm (make-object bitmap% scale-w scale-h)]
[new-mask (make-object bitmap% scale-w scale-h)])
(send new-bm set-loaded-mask new-mask)
[new-mask (and orig-mask (make-object bitmap% scale-w scale-h))])
(when new-mask
(send new-bm set-loaded-mask new-mask))
(send bdc set-bitmap new-bm)
(send bdc set-scale x-scale y-scale)
(send bdc clear)
(send bdc draw-bitmap orig-bm 0 0)
(send bdc set-bitmap new-mask)
(send bdc set-scale x-scale y-scale)
(send bdc clear)
(send bdc draw-bitmap orig-mask 0 0)
(when new-mask
(send bdc set-bitmap new-mask)
(send bdc set-scale x-scale y-scale)
(send bdc clear)
(send bdc draw-bitmap orig-mask 0 0))
(send bdc set-bitmap #f)
@ -734,6 +736,6 @@ the mask bitmap and the original bitmap are all together in a single bytes!
render-image)
;; method names
(provide get-shape get-bb get-normalized?)
(provide get-shape get-bb get-normalized? get-normalized-shape)
(provide np-atomic-shape? atomic-shape? simple-shape?)

4
collects/mrlib/private/image-core-bitmap.ss
View File

@ -59,8 +59,8 @@ instead of this scaling code, we use the dc<%>'s scaling code.
[h (send bm get-height)]
[bytes (make-bytes (* w h NUM-CHANNELS) 0)])
(send bm get-argb-pixels 0 0 w h bytes #f)
(when (send bm get-loaded-mask)
(send (send bm get-loaded-mask) get-argb-pixels 0 0 w h bytes #t))
(when mask
(send mask get-argb-pixels 0 0 w h bytes #t))
(values bytes w h)))
(define (bytes->bitmap bytes w h)

116
collects/mzlib/compile.ss
View File

@ -1,57 +1,63 @@
#lang scheme/base
(require scheme/function
scheme/path
scheme/file)
(provide compile-file)
(module compile mzscheme
(require "file.ss"
"port.ss")
(provide compile-file)
;; (require compiler/src2src)
(define compile-file
(case-lambda
[(src)
(let-values ([(base name dir?) (split-path src)])
(let ([cdir (build-path
(if (symbol? base)
'same
base)
"compiled")])
(unless (directory-exists? cdir)
(make-directory cdir))
(compile-file src (build-path cdir (path-add-suffix name #".zo")))))]
[(src dest) (compile-file src dest values)]
[(src dest filter)
(let ([in (open-input-file src)])
(dynamic-wind
void
(lambda ()
(port-count-lines! in)
(with-handlers ([void
(lambda (exn)
(with-handlers ([void void])
(delete-file dest))
(raise exn))])
(let ([out (open-output-file dest 'truncate/replace)]
[ok? #f])
(let ([dir (let-values ([(base name dir?) (split-path src)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory))))])
(parameterize ([current-load-relative-directory dir]
[current-write-relative-directory dir])
(dynamic-wind
void
(lambda ()
(let loop ()
(let ([r (read-syntax src in)])
(unless (eof-object? r)
(write (compile-syntax (filter (namespace-syntax-introduce r))) out)
(loop))))
(set! ok? #t))
(lambda ()
(close-output-port out)
(unless ok?
(with-handlers ([void void])
(delete-file dest))))))))))
(lambda () (close-input-port in))))
dest])))
(define compile-file
(case-lambda
[(src)
(define cdir (build-path (path-only src) "compiled"))
(make-directory* cdir)
(compile-file src (build-path cdir (path-add-suffix (file-name-from-path src) #".zo")))]
[(src dest)
(compile-file src dest values)]
[(src dest filter)
(define in (open-input-file src))
(dynamic-wind
void
(lambda ()
(define ok? #f)
; This must be based on the path to dest. Renaming typically cannot be done
; atomically across file systems, so the temporary directory is not an option
; because it is often a ram disk. src (or dir below) couldn't be used because
; it may be on a different filesystem. Since dest must be a file path, this
; guarantees that the temp file is in the same directory. It would take a weird
; filesystem configuration to break that.
(define temp-filename (make-temporary-file "tmp~a" #f (path-only dest)))
(port-count-lines! in)
(dynamic-wind
void
(lambda ()
; XXX: This seems like it should be a library function named 'relative-path-only'
(define dir
(let-values ([(base name dir?) (split-path src)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory)))))
(define out (open-output-file temp-filename #:exists 'truncate/replace))
(parameterize ([current-load-relative-directory dir]
[current-write-relative-directory dir])
; Rather than installing a continuation barrier, we detect reinvocation.
; The only thing that can cause reinvocation is if the filter captures the
; continuation and communicates it externally.
(define count 0)
(dynamic-wind
(lambda ()
(if (zero? count)
(set! count 1)
(error 'compile-file "filter function should not be re-entrant")))
(lambda ()
(for ([r (in-port (curry read-syntax src) in)])
(write (compile-syntax (filter (namespace-syntax-introduce r))) out))
(set! ok? #t))
(lambda ()
(close-output-port out)))))
(lambda ()
(if ok?
(rename-file-or-directory temp-filename dest)
(with-handlers ([exn:fail:filesystem? void])
(delete-file temp-filename))))))
(lambda () (close-input-port in)))
dest]))

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

@ -6,13 +6,14 @@
[planet-get-info get-info]))
(define-values (planet-read planet-read-syntax planet-get-info)
(make-meta-reader 'planet
"planet path"
(lambda (str)
(let ([str (bytes->string/latin-1 str)])
(if (module-path? `(planet ,(string->symbol str)))
`(planet ,(string->symbol (string-append str "/lang/reader")))
#f)))
values
values
values)))
(make-meta-reader
'planet
"planet path"
(lambda (str)
(let ([str (bytes->string/latin-1 str)])
(if (module-path? `(planet ,(string->symbol str)))
`(planet ,(string->symbol (string-append str "/lang/reader")))
#f)))
values
values
values)))

16
collects/reader/lang/reader.ss
View File

@ -6,11 +6,11 @@
[-get-info get-info]))
(define-values (-read -read-syntax -get-info)
(make-meta-reader 'reader
"language path"
#:read-spec (lambda (in) (read in))
(lambda (s)
(and (module-path? s) s))
values
values
values)))
(make-meta-reader
'reader
"language path"
#:read-spec (lambda (in) (read in))
(lambda (s) (and (module-path? s) s))
values
values
values)))

6
collects/redex/private/matcher.ss
View File

@ -712,12 +712,6 @@ before the pattern compiler is invoked.
[(has-underscore? pattern)
(let*-values ([(binder before-underscore)
(let ([before (split-underscore pattern)])
(unless (or (hash-maps? clang-ht before)
(memq before underscore-allowed))
(error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s"
before
(format "~s" (list* 'one 'of: (hash-map clang-ht (λ (x y) x))))
pattern))
(values pattern before))]
[(match-raw-name has-hole?)
(compile-id-pattern before-underscore)])

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

@ -1,4 +1,4 @@
(module rewrite-side-conditions scheme/base
(module rewrite-side-conditions scheme
(require (lib "list.ss")
"underscore-allowed.ss")
(require (for-template
@ -74,6 +74,20 @@
[(cross a) #`(cross #,(loop #'a))]
[(cross a ...) (expected-exact 'cross 1 term)]
[cross (expected-arguments 'cross term)]
[_
(identifier? term)
(match (regexp-match #rx"^([^_]*)_.*" (symbol->string (syntax-e term)))
[(list _ (app string->symbol s))
(if (or (memq s (cons '... underscore-allowed))
(memq s all-nts))
term
(raise-syntax-error
what
(format "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s"
s (syntax-e term))
orig-stx
term))]
[_ term])]
[(terms ...)
(map loop (syntax->list (syntax (terms ...))))]
[else

97
collects/redex/private/term-test.ss
View File

@ -1,9 +1,7 @@
(module term-test scheme
(require "term.ss"
"matcher.ss"
"test-util.ss"
errortrace/errortrace-lib
errortrace/errortrace-key)
"test-util.ss")
(reset-count)
(test (term 1) 1)
@ -105,58 +103,75 @@
(define-namespace-anchor here)
(define ns (namespace-anchor->namespace here))
(define (runtime-error-source sexp src)
(let/ec return
(cadar
(continuation-mark-set->list
(exn-continuation-marks
(with-handlers ((exn:fail? values))
(parameterize ([current-namespace ns])
(parameterize ([current-compile (make-errortrace-compile-handler)])
(eval (read-syntax src (open-input-string (format "~s" sexp))))))
(return 'no-source)))
errortrace-key))))
(let ([src 'term-template])
(test
(runtime-error-source
'(term-let ([(x ...) '(a b c)]
[((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
(term (((x y) ...) ...)))
src)
(parameterize ([current-namespace ns])
(runtime-error-source
'(term-let ([(x ...) '(a b c)]
[((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
(term (((x y) ...) ...)))
src))
src))
(let ([src 'term-template-metafunc])
(test
(runtime-error-source
'(term-let-fn ((f car))
(term-let ([(x ...) '(a b c)]
[((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
(term ((((f x) y) ...) ...))))
src)
(parameterize ([current-namespace ns])
(runtime-error-source
'(term-let-fn ((f car))
(term-let ([(x ...) '(a b c)]
[((y ...) ...) '((1 2) (4 5 6) (7 8 9))])
(term ((((f x) y) ...) ...))))
src))
src))
(let ([src 'ellipsis-args])
(test
(parameterize ([current-namespace ns])
(runtime-error-source
'(term-let-fn ((f car))
(term-let ([(x ...) '(a b)]
[(y ...) '(c d e)])
(term (f ((x y) ...)))))
src))
src))
(let ([src 'ellipsis-args/map])
(test
(parameterize ([current-namespace ns])
(runtime-error-source
'(term-let-fn ((f car))
(term-let ([(x ...) '(a b)]
[(y ...) '(c d e)])
(term ((f (x y)) ...))))
src))
src))
(let ([src 'ellipsis-args/in-hole])
(test
(parameterize ([current-namespace ns])
(runtime-error-source
'(term-let ([(x ...) '(a b)]
[(y ...) '(c d e)])
(term ((in-hole hole (x y)) ...)))
src))
src))
(let ([src 'term-let-rhs])
(test
(runtime-error-source
'(term-let ([(x ...) 'a])
3)
src)
(parameterize ([current-namespace ns])
(runtime-error-source
'(term-let ([(x ...) 'a])
3)
src))
src))
(define (syntax-error-sources sexp src)
(let ([p (read-syntax src (open-input-string (format "~s" sexp)))])
(with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x)))))
(parameterize ([current-namespace ns])
(expand p))
null)))
(let ([src 'term-template])
(test
(syntax-error-sources
'(term-let ([(x ...) '(a b c)])
(term x))
src)
(parameterize ([current-namespace ns])
(syntax-error-sources
'(term-let ([(x ...) '(a b c)])
(term x))
src))
(list src)))
(print-tests-passed 'term-test.ss))

10
collects/redex/private/term.ss
View File

@ -32,11 +32,11 @@
(let ([result-id (car (generate-temporaries '(f-results)))])
(with-syntax ([fn fn])
(let loop ([func (syntax (λ (x) (fn (syntax->datum x))))]
[args rewritten]
[args-stx rewritten]
[res result-id]
[args-depth (min depth max-depth)])
(with-syntax ([func func]
[args args]
[args args-stx]
[res res])
(if (zero? args-depth)
(begin
@ -45,7 +45,7 @@
outer-bindings))
(values result-id (min depth max-depth)))
(loop (syntax (λ (l) (map func (syntax->list l))))
(syntax (args (... ...)))
(syntax/loc args-stx (args (... ...)))
(syntax (res (... ...)))
(sub1 args-depth)))))))))
@ -55,7 +55,7 @@
(and (identifier? (syntax metafunc-name))
(term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f))))
(rewrite-application (term-fn-get-id (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t)))
(syntax (arg ...))
(syntax/loc stx (arg ...))
depth)]
[f
(and (identifier? (syntax f))
@ -76,7 +76,7 @@
[(unquote-splicing . x)
(raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)]
[(in-hole id body)
(rewrite-application (syntax (λ (x) (apply plug x))) (syntax (id body)) depth)]
(rewrite-application (syntax (λ (x) (apply plug x))) (syntax/loc stx (id body)) depth)]
[(in-hole . x)
(raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
[hole (values (syntax (unsyntax the-hole)) 0)]

24
collects/redex/private/test-util.ss
View File

@ -1,10 +1,13 @@
#lang scheme
(require "matcher.ss")
(require "matcher.ss"
errortrace/errortrace-lib
errortrace/errortrace-key)
(provide test test-syn-err tests reset-count
syn-err-test-namespace
print-tests-passed
equal/bindings?)
equal/bindings?
runtime-error-source syntax-error-sources)
(define syn-err-test-namespace (make-base-namespace))
(parameterize ([current-namespace syn-err-test-namespace])
@ -108,3 +111,20 @@
;; rib-lt : rib rib -> boolean
(define (rib-lt r1 r2) (string<=? (format "~s" (bind-name r1))
(format "~s" (bind-name r2))))
(define (runtime-error-source sexp src)
(let/ec return
(cadar
(continuation-mark-set->list
(exn-continuation-marks
(with-handlers ((exn:fail? values))
(parameterize ([current-compile (make-errortrace-compile-handler)])
(eval (read-syntax src (open-input-string (format "~s" sexp)))))
(return 'no-source)))
errortrace-key))))
(define (syntax-error-sources sexp src)
(let ([p (read-syntax src (open-input-string (format "~s" sexp)))])
(with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x)))))
(expand p)
null)))

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

@ -261,7 +261,16 @@
(term (f 1)))
(test rhs-eval-count 2))
(define-namespace-anchor here)
(define ns (namespace-anchor->namespace here))
(let ([src 'bad-underscore])
(test
(parameterize ([current-namespace ns])
(syntax-error-sources
'(define-language L (n m_1))
src))
(list src)))
;
;

6
collects/redex/redex.scrbl
View File

@ -128,7 +128,7 @@ in the grammar are terminals.
@itemize[
@item{The @defpattech[any] @pattern matches any sepxression.
@item{The @defpattech[any] @pattern matches any sexpression.
This @pattern may also be suffixed with an underscore and another
identifier, in which case they bind the full name (as if it
were an implicit @pattech[name] @pattern) and match the portion
@ -192,9 +192,9 @@ symbol except those that are used as literals elsewhere in
the language.
}
@item{The @defpattech[hole] @pattern matches anything when inside a matching
@item{The @defpattech[hole] @pattern matches anything when inside
the first argument to an @pattech[in-hole] @|pattern|. Otherwise,
it matches only the hole.
it matches only a hole.
}
@item{The @defpattech[symbol] @pattern stands for a literal symbol that must

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "23nov2009")
#lang scheme/base (provide stamp) (define stamp "9dec2009")

10
collects/scheme/contract/private/guts.ss
View File

@ -66,9 +66,14 @@
(define-values (flat-prop flat-pred? flat-get)
(make-struct-type-property 'contract-flat))
(define-values (first-order-prop first-order-pred? first-order-get)
(define-values (first-order-prop first-order-pred? raw-first-order-get)
(make-struct-type-property 'contract-first-order))
(define (first-order-get stct)
(cond
[(flat-pred? stct) (flat-get stct)]
[else (raw-first-order-get stct)]))
(define (contract-first-order-passes? c v)
(let ([ctc (coerce-contract 'contract-first-order-passes? c)])
(cond
@ -404,7 +409,8 @@
#:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))
#:property first-order-prop
(λ (ctc)
(let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
(let ([tests (map (λ (x) ((first-order-get x) x))
(and/c-ctcs ctc))])
(λ (x)
(andmap (λ (f) (f x)) tests))))
#:property stronger-prop

23
collects/scheme/contract/private/opt-guts.ss
View File

@ -56,8 +56,14 @@
;; struct for color-keeping across opters
(define-struct opt/info (contract val pos neg src-info orig-str positive-position?
free-vars recf base-pred this that))
(define-struct opt/info
(contract val pos neg src-info orig-str position-var position-swap?
free-vars recf base-pred this that))
(define (opt/info-positive-position? oi)
(if (opt/info-position-swap? oi)
#`(not #,(opt/info-position-var oi))
(opt/info-position-var oi)))
;; opt/info-swap-blame : opt/info -> opt/info
;; swaps pos and neg
@ -66,7 +72,8 @@
(val (opt/info-val info))
(pos (opt/info-pos info))
(neg (opt/info-neg info))
(positive-position? (opt/info-positive-position? info))
(position-var (opt/info-position-var info))
(position-swap? (opt/info-position-swap? info))
(src-info (opt/info-src-info info))
(orig-str (opt/info-orig-str info))
(free-vars (opt/info-free-vars info))
@ -74,7 +81,8 @@
(base-pred (opt/info-base-pred info))
(this (opt/info-this info))
(that (opt/info-that info)))
(make-opt/info ctc val neg pos src-info orig-str (not positive-position?)
(make-opt/info ctc val neg pos src-info orig-str
position-var (not position-swap?)
free-vars recf base-pred this that)))
;; opt/info-change-val : identifier opt/info -> opt/info
@ -83,7 +91,8 @@
(let ((ctc (opt/info-contract info))
(pos (opt/info-pos info))
(neg (opt/info-neg info))
(positive-position? (opt/info-positive-position? info))
(position-var (opt/info-position-var info))
(position-swap? (opt/info-position-swap? info))
(src-info (opt/info-src-info info))
(orig-str (opt/info-orig-str info))
(free-vars (opt/info-free-vars info))
@ -91,7 +100,9 @@
(base-pred (opt/info-base-pred info))
(this (opt/info-this info))
(that (opt/info-that info)))
(make-opt/info ctc val pos neg src-info orig-str positive-position? free-vars recf base-pred this that)))
(make-opt/info ctc val pos neg src-info orig-str
position-var position-swap?
free-vars recf base-pred this that)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1
collects/scheme/contract/private/opt.ss
View File

@ -127,6 +127,7 @@
#'src-info
#'orig-str
#'positive-position?
#f
(syntax->list #'(opt-recursive-args ...))
#f
#f

21
collects/scheme/foreign.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
;; Foreign Scheme interface
(require '#%foreign setup/dirs
(require '#%foreign setup/dirs scheme/unsafe/ops
(for-syntax scheme/base scheme/list syntax/stx))
;; This module is full of unsafe bindings that are not provided to requiring
@ -1081,7 +1081,8 @@
[TAG-set! (id "" "-set!")]
[_TAG (id "_" "")]
[_TAG* (id "_" "*")]
[TAGname name])
[TAGname name]
[f64? (if (eq? (syntax-e #'TAG) 'f64) #'#t #'#f)])
#'(begin
(define-struct TAG (ptr length))
(provide TAG? TAG-length (rename-out [TAG s:TAG]))
@ -1102,14 +1103,19 @@
(define* (TAG-ref v i)
(if (TAG? v)
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
(ptr-ref (TAG-ptr v) type i)
(if f64? ;; use JIT-inlined operation
(unsafe-f64vector-ref v i)
(ptr-ref (TAG-ptr v) type i))
(error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
i 'TAG (sub1 (TAG-length v))))
(raise-type-error 'TAG-ref TAGname v)))
(define* (TAG-set! v i x)
(if (TAG? v)
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
(ptr-set! (TAG-ptr v) type i x)
(if (and f64? ;; use JIT-inlined operation
(inexact-real? x))
(unsafe-f64vector-set! v i x)
(ptr-set! (TAG-ptr v) type i x))
(error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
i 'TAG (sub1 (TAG-length v))))
(raise-type-error 'TAG-set! TAGname v)))
@ -1264,9 +1270,10 @@
(raise-type-error 'cast "ctype" to-type))
(unless (= (ctype-sizeof to-type)
(ctype-sizeof from-type))
(raise-mismatch-error (format "representation sizes of types differ: ~e to "
from-type)
to-type))
(raise-mismatch-error 'cast
(format "representation sizes of from and to types differ: ~e and "
(ctype-sizeof from-type))
(ctype-sizeof to-type)))
(let ([p2 (malloc from-type)])
(ptr-set! p2 from-type p)
(ptr-ref p2 to-type)))

2
collects/scheme/mzscheme.ss
View File

@ -16,7 +16,7 @@
"private/old-procs.ss"
"private/map.ss" ; shadows #%kernel bindings
"private/kernstruct.ss"
"promise.ss"
"private/promise.ss"
(only "private/cond.ss" old-cond)
"tcp.ss"
"udp.ss"

16
collects/scheme/package.ss
View File

@ -317,9 +317,11 @@
(let* ([def-ctx (if star?
(syntax-local-make-definition-context (car def-ctxes))
(last def-ctxes))]
[ids (if star?
(map (add-package-context (list def-ctx)) ids)
ids)])
[ids (map
(lambda (id) (syntax-property id 'unshadowable #t))
(if star?
(map (add-package-context (list def-ctx)) ids)
ids))])
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
(register-bindings! ids)
(loop (cdr exprs)
@ -335,9 +337,11 @@
(let* ([def-ctx (if star?
(syntax-local-make-definition-context (car def-ctxes))
(last def-ctxes))]
[ids (if star?
(map (add-package-context (list def-ctx)) ids)
ids)])
[ids (map
(lambda (id) (syntax-property id 'unshadowable #t))
(if star?
(map (add-package-context (list def-ctx)) ids)
ids))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(register-bindings! ids)
(loop (cdr exprs)

71
collects/scheme/private/at-syntax.ss
View File

@ -1,71 +0,0 @@
#lang scheme/base
(require (for-template scheme/base))
(provide at-syntax)
;; -------------------------------------------------------------------
;; NOTE: This library is for internal use only, it is can change
;; and/or disappear. Do not use without protective eyewear!
;; -------------------------------------------------------------------
#|
The `(at-syntax expr)' form is a useful syntax-time utility that can
be used to sort of evaluate an expression at syntax time, and doing so
in a well behaved way (eg, it respects the source for-syntax bindings,
but it does have some issues). It can be used to implement an escape
to the syntax level that is not restricted like `begin-for-syntax'.
The basic idea of the code is to plant the given expression on the
right hand side of a `let-syntax' -- inside a `(lambda (stx) ...)' to
make it a valid transformer, with a singe use of this macro so that we
get it to execute with `local-expand'. The macro returns a 3d
expression that contains the evaluated expression "somehwhere",
depending on the expansion of `let-syntax' -- so to make it easy to
find we plant it inside a thunk (so this works as long as `let-syntax'
does not include 3d procedure values in its expansion). Finally, the
constructed `let-syntax' is expanded, we search through the resulting
syntax for the thunk, then apply it to get the desired value.
Here's a silly example to demonstrate:
> (define-syntax (compile-time-if stx)
(syntax-case stx ()
[(_ cond expr1 expr2)
(if (at-syntax #'cond) #'expr1 #'expr2)]))
> (define-for-syntax x 8)
> (define x 100)
> (compile-time-if (< x 10) (+ x 10) (- x 10))
110
And another example, creating a macro for syntax-time expressions:
> (define-syntax (compile-time-value stx)
(syntax-case stx ()
[(_ expr) #`(quote #,(at-syntax #'expr))]))
> (compile-time-value (* x 2))
16
but the `quote' here is a hint that this can get 3d values into
syntax, and all the problems that are involved. Also, note that it
breaks if you try to do something like:
> (compile-time-value (begin (set! x 11) x))
8
(and, of course, it cannot be used to define new bindings).
|#
(define (at-syntax expr)
(let loop ([x (with-syntax ([e expr])
(local-expand
#'(let-syntax ([here (lambda (stx)
(datum->syntax stx (lambda () e)))])
here)
'expression '()))])
(cond [(procedure? x) (x)]
[(pair? x) (or (loop (car x)) (loop (cdr x)))]
[(syntax? x) (loop (syntax-e x))]
[else #f])))

4
collects/scheme/private/for.ss
View File

@ -469,8 +469,8 @@
(define in-port
(case-lambda
[() (in-port (current-input-port) read)]
[(r) (in-port (current-input-port) r)]
[() (in-port read (current-input-port))]
[(r) (in-port r (current-input-port))]
[(r p)
(unless (and (procedure? r) (procedure-arity-includes? r 1))
(raise-type-error 'in-port "procedure (arity 1)" r))

269
collects/scheme/private/promise.ss Normal file
View File

@ -0,0 +1,269 @@
(module promise '#%kernel
(#%require "small-scheme.ss"
"more-scheme.ss"
"define.ss"
(rename "define-struct.ss" define-struct define-struct*)
(for-syntax '#%kernel "stxcase-scheme.ss" "name.ss")
'#%unsafe)
(#%provide force promise? promise-forced? promise-running?
;; provided to create extensions
(struct promise ()) pref pset! prop:force reify-result
promise-printer
(struct running ()) (struct reraise ())
(for-syntax make-delayer))
;; This module implements "lazy" (composable) promises and a `force'
;; that is iterated through them.
;; This is similar to the *new* version of srfi-45 -- see the
;; post-finalization discussion at http://srfi.schemers.org/srfi-45/ for
;; more details; specifically, this version is the `lazy2' version from
;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html.
;; Note: if you use only `force'+`delay' it behaves as in Scheme (except
;; that `force' is identity for non promise values), and `force'+`lazy'
;; are sufficient for implementing the lazy language.
;; unsafe accessors
(define-syntax pref (syntax-rules () [(_ p ) (unsafe-struct-ref p 0 )]))
(define-syntax pset! (syntax-rules () [(_ p x) (unsafe-struct-set! p 0 x)]))
;; ----------------------------------------------------------------------------
;; Forcers
;; force/composable iterates on composable promises
;; * (force X) = X for non promises
;; * does not deal with multiple values in the composable case
(define (force/composable root)
(let ([v (pref root)])
(cond
[(procedure? v)
;; mark the root as running: avoids cycles, and no need to keep banging
;; the root promise value; it makes this non-r5rs, but the only
;; practical uses of these things could be ones that use state to avoid
;; an infinite loop. (See the generic forcer below.)
;; (careful: avoid holding a reference to the thunk, to allow
;; safe-for-space loops)
(pset! root (make-running (object-name v)))
(call-with-exception-handler
(lambda (e) (pset! root (make-reraise e)) e)
(lambda ()
;; iterate carefully through chains of composable promises
(let loop ([v (v)]) ; does not handle multiple values!
(cond [(composable-promise? v)
(let ([v* (pref v)])
(pset! v root) ; share with root
(cond [(procedure? v*) (loop (v*))]
;; it must be a list of one value (because
;; composable promises never hold multiple values),
;; or a composable promise
[(pair? v*) (pset! root v*) (unsafe-car v*)]
;; note: for the promise case we could jump only to
;; the last `let' (for `v*'), but that makes the
;; code heavier, and runs slower (probably goes over
;; some inlining/unfolding threshold).
[else (loop v*)]))]
;; reached a non-composable promise: share and force it now
[(promise? v) (pset! root v) (force v)]
;; error here for "library approach" (see above URL)
[else (pset! root (list v)) v]))))]
;; try to make the order efficient, with common cases first
[(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
;; follow all sharings (and shortcut directly to the right force)
[(composable-promise? v) (force/composable v) (force v)]
[(null? v) (values)]
[else (error 'force "composable promise with invalid contents: ~e" v)])))
(define (reify-result v)
(cond [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
[(null? v) (values)]
[(reraise? v) (v)]
[else (error 'force "promise with invalid contents: ~e" v)]))
;; generic force for "old-style" promises -- they're still useful in
;; that they allow multiple values. In general, this is slower, but has
;; more features. (They could allow self loops, but this means holding
;; on to the procedure and its resources while it is running, and lose
;; the ability to know that it is running; the second can be resolved
;; with a new kind of `running' value that can be used again, but the
;; first cannot be solved. I still didn't ever see any use for them, so
;; they're still forbidden.)
(define (force/generic promise)
(reify-result
(let ([v (pref promise)])
(if (procedure? v)
(begin
(pset! promise (make-running (object-name v)))
(call-with-exception-handler
(lambda (e) (pset! promise (make-reraise e)) e)
(lambda ()
(let ([vs (call-with-values v list)]) (pset! promise vs) vs))))
v))))
;; dispatcher for composable promises, generic promises, and other values
(define (force promise)
(if (promise? promise)
((promise-forcer promise) promise) ; dispatch to specific forcer
promise)) ; different from srfi-45: identity for non-promises
;; ----------------------------------------------------------------------------
;; Struct definitions
;; generic promise printer
(define (promise-printer promise port write?)
(let loop ([v (pref promise)])
(cond
[(reraise? v)
(let ([r (reraise-val v)])
(if (exn? r)
(fprintf port (if write? "#<promise!exn!~s>" "#<promise!exn!~a>")
(exn-message r))
(fprintf port (if write? "#<promise!raise!~s>" "#<promise!raise!~a>")
r)))]
[(running? v)
(let ([r (running-name v)])
(if r
(fprintf port "#<promise:!running!~a>" r)
(fprintf port "#<promise:!running>")))]
[(procedure? v)
(cond [(object-name v)
=> (lambda (n) (fprintf port "#<promise:~a>" n))]
[else (display "#<promise>" port)])]
[(promise? v) (loop (pref v))] ; hide sharing
;; values
[(null? v) (fprintf port "#<promise!(values)>")]
[(null? (cdr v))
(fprintf port (if write? "#<promise!~s>" "#<promise!~a>") (car v))]
[else (display "#<promise!(values" port)
(let ([fmt (if write? " ~s" " ~a")])
(for-each (lambda (x) (fprintf port fmt x)) v))
(display ")>" port)])))
;; property value for the right forcer to use
(define-values [prop:force promise-forcer]
(let-values ([(prop pred? get) ; no need for the predicate
(make-struct-type-property 'forcer
(lambda (v info)
(unless (and (procedure? v)
(procedure-arity-includes? v 1))
(raise-type-error 'prop:force "a unary function" v))
v))])
(values prop get)))
;; A promise value can hold
;; - (list <value> ...): forced promise (possibly multiple-values)
;; - composable promises deal with only one value
;; - <promise>: a shared (redirected) promise that points at another one
;; - possible only with composable promises
;; - <thunk>: usually a delayed promise,
;; - can also hold a `running' thunk that will throw a reentrant error
;; - can also hold a raising-a-value thunk on exceptions and other
;; `raise'd values (actually, applicable structs for printouts)
;; First, a generic struct, which is used for all promise-like values
(define-struct promise ([val #:mutable])
#:property prop:custom-write promise-printer
#:property prop:force force/generic)
;; Then, a subtype for composable promises
(define-struct (composable-promise promise) ()
#:property prop:force force/composable)
;; template for all delay-like constructs
;; (with simple keyword matching: keywords is an alist with default exprs)
(define-for-syntax (make-delayer stx maker keywords)
;; no `cond', `and', `or', `let', `define', etc here
(letrec-values
([(exprs+kwds)
(lambda (stxs exprs kwds)
(if (null? stxs)
(values (reverse exprs) (reverse kwds))
(if (not (keyword? (syntax-e (car stxs))))
(exprs+kwds (cdr stxs) (cons (car stxs) exprs) kwds)
(if (if (pair? (cdr stxs))
(if (assq (syntax-e (car stxs)) keywords)
(not (assq (syntax-e (car stxs)) kwds))
#f)
#f)
(exprs+kwds (cddr stxs) exprs
(cons (cons (syntax-e (car stxs)) (cadr stxs))
kwds))
(values #f #f)))))]
[(stxs) (syntax->list stx)]
[(exprs kwds) (exprs+kwds (if stxs (cdr stxs) '()) '() '())]
[(kwd-args) (if kwds
(map (lambda (k)
(let-values ([(x) (assq (car k) kwds)])
(if x (cdr x) (cdr k))))
keywords)
#f)]
;; some strange bug with `syntax-local-expand-expression' makes this not
;; work well with identifiers, so turn the name into a symbol to work
;; around this for now
[(name0) (syntax-local-infer-name stx)]
[(name) (if (syntax? name0) (syntax-e name0) name0)])
(syntax-case stx ()
[_ (pair? exprs) ; throw a syntax error if anything is wrong
(with-syntax ([(expr ...) exprs]
[(kwd-arg ...) kwd-args])
(with-syntax ([proc (syntax-property
(syntax/loc stx (lambda () expr ...))
'inferred-name name)]
[make maker])
(syntax/loc stx (make proc kwd-arg ...))))])))
;; Creates a composable promise
;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
(#%provide (rename lazy* lazy))
(define lazy make-composable-promise)
(define-syntax (lazy* stx) (make-delayer stx #'lazy '()))
;; Creates a (generic) promise that does not compose
;; X = (force (delay X)) = (force (lazy (delay X)))
;; = (force (lazy^n (delay X)))
;; X = (force (force (delay (delay X)))) != (force (delay (delay X)))
;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a
;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0)
;; (This is not needed with a lazy language (see the above URL for details),
;; but provided for regular delay/force uses.)
(#%provide (rename delay* delay))
(define delay make-promise)
(define-syntax (delay* stx) (make-delayer stx #'delay '()))
;; For simplicity and efficiency this code uses thunks in promise values for
;; exceptions: this way, we don't need to tag exception values in some special
;; way and test for them -- we just use a thunk that will raise the exception.
;; But it's still useful to refer to the exception value, so use an applicable
;; struct for them. The same goes for a promise that is being forced: we use a
;; thunk that will throw a "reentrant promise" error -- and use an applicable
;; struct so it is identifiable.
(define-struct reraise (val)
#:property prop:procedure (lambda (this) (raise (reraise-val this))))
(define-struct running (name)
#:property prop:procedure (lambda (this)
(let ([name (running-name this)])
(if name
(error 'force "reentrant promise ~e" name)
(error 'force "reentrant promise")))))
;; ----------------------------------------------------------------------------
;; Utilities
(define (promise-forced? promise)
(if (promise? promise)
(let ([v (pref promise)])
(or (not (procedure? v)) (reraise? v))) ; #f when running
(raise-type-error 'promise-forced? "promise" promise)))
(define (promise-running? promise)
(if (promise? promise)
(running? (pref promise))
(raise-type-error 'promise-running? "promise" promise)))
)
#|
Simple code for timings:
(define (c n) (lazy (if (zero? n) (delay 'hey!) (c (sub1 n)))))
(for ([i (in-range 9)])
(collect-garbage) (collect-garbage) (collect-garbage)
(time (for ([i (in-range 10000)]) (force (c 2000)))))
Also, run (force (c -1)) and check constant space
|#

18
collects/scheme/private/sort.ss
View File

@ -76,14 +76,16 @@ doing these checks.
(loop a1 b1 c1)))))))))
(define-syntax-rule (copying-insertionsort Alo Blo n)
(let iloop ([i 0] [A Alo])
(when (i< i n)
(let ([ref-i (ref A)])
(let jloop ([j (i+ Blo i)])
(let ([ref-j-1 (ref (i- j 1))])
(if (and (i< Blo j) (<? ref-i ref-j-1))
(begin (set! j ref-j-1) (jloop (i- j 1)))
(begin (set! j ref-i) (iloop (i+ i 1) (i+ A 1))))))))))
;; n is never 0
(begin (set! Blo (ref Alo))
(let iloop ([i 1])
(when (i< i n)
(let ([ref-i (ref (i+ Alo i))])
(let jloop ([j (i+ Blo i)])
(let ([ref-j-1 (ref (i- j 1))])
(if (and (i< Blo j) (<? ref-i ref-j-1))
(begin (set! j ref-j-1) (jloop (i- j 1)))
(begin (set! j ref-i) (iloop (i+ i 1)))))))))))
(define (copying-mergesort Alo Blo n)
(cond

286
collects/scheme/promise.ss
View File

@ -1,257 +1,6 @@
(module promise '#%kernel
(#%require "private/small-scheme.ss"
"private/more-scheme.ss"
"private/define.ss"
(rename "private/define-struct.ss" define-struct define-struct*)
(for-syntax '#%kernel "private/stxcase-scheme.ss" "private/name.ss")
'#%unsafe)
(#%provide force promise? promise-forced? promise-running?)
;; This module implements "lazy" (composable) promises and a `force'
;; that is iterated through them.
;; This is similar to the *new* version of srfi-45 -- see the
;; post-finalization discussion at http://srfi.schemers.org/srfi-45/ for
;; more details; specifically, this version is the `lazy2' version from
;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html.
;; Note: if you use only `force'+`delay' it behaves as in Scheme (except
;; that `force' is identity for non promise values), and `force'+`lazy'
;; are sufficient for implementing the lazy language.
;; unsafe accessors
(define-syntax pref (syntax-rules () [(_ p) (unsafe-struct-ref p 0)]))
(define-syntax pset! (syntax-rules () [(_ p x) (unsafe-struct-set! p 0 x)]))
;; ----------------------------------------------------------------------------
;; Forcers
;; force/composable iterates on composable promises
;; * (force X) = X for non promises
;; * does not deal with multiple values in the composable case
(define (force/composable root)
(let ([v (pref root)])
(cond
[(procedure? v)
;; mark the root as running: avoids cycles, and no need to keep banging
;; the root promise value; it makes this non-r5rs, but the only
;; practical uses of these things could be ones that use state to avoid
;; an infinite loop. (See the generic forcer below.)
;; (careful: avoid holding a reference to the thunk, to allow
;; safe-for-space loops)
(pset! root (make-running (object-name v)))
(call-with-exception-handler
(lambda (e) (pset! root (make-reraise e)) e)
(lambda ()
;; iterate carefully through chains of composable promises
(let loop ([v (v)]) ; does not handle multiple values!
(cond [(composable-promise? v)
(let ([v* (pref v)])
(pset! v root) ; share with root
(cond [(procedure? v*) (loop (v*))]
;; it must be a list of one value (because
;; composable promises never hold multiple values),
;; or a composable promise
[(pair? v*) (pset! root v*) (unsafe-car v*)]
;; note: for the promise case we could jump only to
;; the last `let' (for `v*'), but that makes the
;; code heavier, and runs slower (probably goes over
;; some inlining/unfolding threshold).
[else (loop v*)]))]
;; reached a non-composable promise: share and force it now
[(promise? v) (pset! root v) (force v)]
;; error here for "library approach" (see above URL)
[else (pset! root (list v)) v]))))]
;; try to make the order efficient, with common cases first
[(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
;; follow all sharings (and shortcut directly to the right force)
[(composable-promise? v) (force/composable v) (force v)]
[(null? v) (values)]
[else (error 'force "composable promise with invalid contents: ~e" v)])))
(define (reify-result v)
(cond
[(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))]
[(null? v) (values)]
[(reraise? v) (v)]
[else (error 'force "promise with invalid contents: ~e" v)]))
;; generic force for "old-style" promises -- they're still useful in
;; that they allow multiple values. In general, this is slower, but has
;; more features. (They could allow self loops, but this means holding
;; on to the procedure and its resources while it is running, and lose
;; the ability to know that it is running; the second can be resolved
;; with a new kind of `running' value that can be used again, but the
;; first cannot be solved. I still didn't ever see any use for them, so
;; they're still forbidden.)
(define (force/generic promise)
(reify-result
(let ([v (pref promise)])
(if (procedure? v)
(begin
(pset! promise (make-running (object-name v)))
(call-with-exception-handler
(lambda (e) (pset! promise (make-reraise e)) e)
(lambda ()
(let ([vs (call-with-values v list)]) (pset! promise vs) vs))))
v))))
;; dispatcher for composable promises, generic promises, and other values
(define (force promise)
(if (promise? promise)
((promise-forcer promise) promise) ; dispatch to specific forcer
promise)) ; different from srfi-45: identity for non-promises
;; ----------------------------------------------------------------------------
;; Struct definitions
;; generic promise printer
(define (promise-printer promise port write?)
(let loop ([v (pref promise)])
(cond
[(reraise? v)
(let ([r (reraise-val v)])
(if (exn? r)
(fprintf port (if write? "#<promise!exn!~s>" "#<promise!exn!~a>")
(exn-message r))
(fprintf port (if write? "#<promise!raise!~s>" "#<promise!raise!~a>")
r)))]
[(running? v)
(let ([r (running-name v)])
(if r
(fprintf port "#<promise:!running!~a>" r)
(fprintf port "#<promise:!running>")))]
[(procedure? v)
(cond [(object-name v)
=> (lambda (n) (fprintf port "#<promise:~a>" n))]
[else (display "#<promise>" port)])]
[(promise? v) (loop (pref v))] ; hide sharing
;; values
[(null? v) (fprintf port "#<promise!(values)>")]
[(null? (cdr v))
(fprintf port (if write? "#<promise!~s>" "#<promise!~a>") (car v))]
[else (display "#<promise!(values" port)
(let ([fmt (if write? " ~s" " ~a")])
(for-each (lambda (x) (fprintf port fmt x)) v))
(display ")>" port)])))
;; property value for the right forcer to use
(define-values [prop:force promise-forcer]
(let-values ([(prop pred? get) ; no need for the predicate
(make-struct-type-property 'forcer
(lambda (v info)
(unless (and (procedure? v)
(procedure-arity-includes? v 1))
(raise-type-error 'prop:force "a unary function" v))
v))])
(values prop get)))
;; A promise value can hold
;; - (list <value> ...): forced promise (possibly multiple-values)
;; - composable promises deal with only one value
;; - <promise>: a shared (redirected) promise that points at another one
;; - possible only with composable promises
;; - <thunk>: usually a delayed promise,
;; - can also hold a `running' thunk that will throw a reentrant error
;; - can also hold a raising-a-value thunk on exceptions and other
;; `raise'd values (actually, applicable structs for printouts)
;; First, a generic struct, which is used for all promise-like values
(define-struct promise ([val #:mutable])
#:property prop:custom-write promise-printer
#:property prop:force force/generic)
;; Then, a subtype for composable promises
(define-struct (composable-promise promise) ()
#:property prop:force force/composable)
;; template for all delay-like constructs
;; (with simple keyword matching: keywords is an alist with default exprs)
(define-for-syntax (make-delayer stx maker keywords)
;; no `cond', `and', `or', `let', `define', etc here
(letrec-values
([(exprs+kwds)
(lambda (stxs exprs kwds)
(if (null? stxs)
(values (reverse exprs) (reverse kwds))
(if (not (keyword? (syntax-e (car stxs))))
(exprs+kwds (cdr stxs) (cons (car stxs) exprs) kwds)
(if (if (pair? (cdr stxs))
(if (assq (syntax-e (car stxs)) keywords)
(not (assq (syntax-e (car stxs)) kwds))
#f)
#f)
(exprs+kwds (cddr stxs) exprs
(cons (cons (syntax-e (car stxs)) (cadr stxs))
kwds))
(values #f #f)))))]
[(stxs) (syntax->list stx)]
[(exprs kwds) (exprs+kwds (if stxs (cdr stxs) '()) '() '())]
[(kwd-args) (if kwds
(map (lambda (k)
(let-values ([(x) (assq (car k) kwds)])
(if x (cdr x) (cdr k))))
keywords)
#f)]
;; some strange bug with `syntax-local-expand-expression' makes this not
;; work well with identifiers, so turn the name into a symbol to work
;; around this for now
[(name0) (syntax-local-infer-name stx)]
[(name) (if (syntax? name0) (syntax-e name0) name0)])
(syntax-case stx ()
[_ (pair? exprs) ; throw a syntax error if anything is wrong
(with-syntax ([(expr ...) exprs]
[(kwd-arg ...) kwd-args])
(with-syntax ([proc (syntax-property
(syntax/loc stx (lambda () expr ...))
'inferred-name name)]
[make maker])
(syntax/loc stx (make proc kwd-arg ...))))])))
;; Creates a composable promise
;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
(#%provide (rename lazy* lazy))
(define lazy make-composable-promise)
(define-syntax (lazy* stx) (make-delayer stx #'lazy '()))
;; Creates a (generic) promise that does not compose
;; X = (force (delay X)) = (force (lazy (delay X)))
;; = (force (lazy^n (delay X)))
;; X = (force (force (delay (delay X)))) != (force (delay (delay X)))
;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a
;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0)
;; (This is not needed with a lazy language (see the above URL for details),
;; but provided for regular delay/force uses.)
(#%provide (rename delay* delay))
(define delay make-promise)
(define-syntax (delay* stx) (make-delayer stx #'delay '()))
;; For simplicity and efficiency this code uses thunks in promise values for
;; exceptions: this way, we don't need to tag exception values in some special
;; way and test for them -- we just use a thunk that will raise the exception.
;; But it's still useful to refer to the exception value, so use an applicable
;; struct for them. The same goes for a promise that is being forced: we use a
;; thunk that will throw a "reentrant promise" error -- and use an applicable
;; struct so it is identifiable.
(define-struct reraise (val)
#:property prop:procedure (lambda (this) (raise (reraise-val this))))
(define-struct running (name)
#:property prop:procedure (lambda (this)
(let ([name (running-name this)])
(if name
(error 'force "reentrant promise ~e" name)
(error 'force "reentrant promise")))))
;; ----------------------------------------------------------------------------
;; Utilities
(define (promise-forced? promise)
(if (promise? promise)
(let ([v (pref promise)])
(or (not (procedure? v)) (reraise? v))) ; #f when running
(raise-type-error 'promise-forced? "promise" promise)))
(define (promise-running? promise)
(if (promise? promise)
(running? (pref promise))
(raise-type-error 'promise-running? "promise" promise)))
#lang scheme/base
(require "private/promise.ss" (for-syntax scheme/base))
(provide delay lazy force promise? promise-forced? promise-running?)
;; ----------------------------------------------------------------------------
;; More delay-like values, with different ways of deferring computations
@ -259,7 +8,7 @@
(define-struct (promise/name promise) ()
#:property prop:force (lambda (p) ((pref p))))
(#%provide (rename delay/name* delay/name))
(provide (rename-out [delay/name* delay/name]))
(define delay/name make-promise/name)
(define-syntax (delay/name* stx) (make-delayer stx #'delay/name '()))
@ -315,7 +64,7 @@
(let ([v (pref p)])
(handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void))))
(#%provide (rename delay/sync* delay/sync))
(provide (rename-out [delay/sync* delay/sync]))
(define (delay/sync thunk)
(let ([done-sema (make-semaphore 0)])
(make-promise/sync (make-syncinfo thunk
@ -339,7 +88,7 @@
(handle-evt (if (running? v) (running-thread-thread v) always-evt)
void))))
(#%provide (rename delay/thread* delay/thread))
(provide (rename-out [delay/thread* delay/thread]))
(define (delay/thread thunk group)
(define (run)
(call-with-exception-handler
@ -354,7 +103,7 @@
(thread run)))))
p)
(define-syntax delay/thread*
(let-values ([(kwds) (list (cons '#:group #'#t))])
(let ([kwds (list (cons '#:group #'#t))])
(lambda (stx) (make-delayer stx #'delay/thread kwds))))
(define-struct (promise/idle promise/thread) ()
@ -371,7 +120,7 @@
(pref p))
v)))))
(#%provide (rename delay/idle* delay/idle))
(provide (rename-out [delay/idle* delay/idle]))
(define (delay/idle thunk wait-for work-while tick use*)
(define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
(define work-time (* tick use))
@ -422,19 +171,8 @@
(or (object-name thunk) 'idle-thread))))
p)
(define-syntax delay/idle*
(let-values ([(kwds) (list (cons '#:wait-for #'(system-idle-evt))
(cons '#:work-while #'(system-idle-evt))
(cons '#:tick #'0.2)
(cons '#:use #'0.12))])
(let ([kwds (list (cons '#:wait-for #'(system-idle-evt))
(cons '#:work-while #'(system-idle-evt))
(cons '#:tick #'0.2)
(cons '#:use #'0.12))])
(lambda (stx) (make-delayer stx #'delay/idle kwds))))
)
#|
Simple code for timings:
(define (c n) (lazy (if (zero? n) (delay 'hey!) (c (sub1 n)))))
(for ([i (in-range 9)])
(collect-garbage) (collect-garbage) (collect-garbage)
(time (for ([i (in-range 10000)]) (force (c 2000)))))
Also, run (force (c -1)) and check constant space
|#

4
collects/scheme/provide.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base scheme/provide-transform scheme/list
"private/at-syntax.ss"))
(only-in unstable/syntax syntax-local-eval)))
(provide matching-identifiers-out)
(define-syntax matching-identifiers-out
@ -21,7 +21,7 @@
(lambda (stx modes)
(syntax-case stx ()
[(_ proc spec)
(let ([proc (at-syntax #'proc)])
(let ([proc (syntax-local-eval #'proc)])
(filter-map
(lambda (e)
(let* ([s1 (symbol->string (export-out-sym e))]

4
collects/scheme/require.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base scheme/require-transform scheme/list
"private/at-syntax.ss")
(only-in unstable/syntax syntax-local-eval))
"require-syntax.ss")
(provide matching-identifiers-in)
@ -43,7 +43,7 @@
(lambda (stx)
(syntax-case stx ()
[(_ proc spec)
(let ([proc (at-syntax #'proc)])
(let ([proc (syntax-local-eval #'proc)])
(define-values [imports sources] (expand-import #'spec))
(values
(filter-map

2
collects/scheme/signature/lang.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/unit
scheme/contract
(for-syntax scheme/base
mzlib/private/unit-compiletime
mzlib/private/unit-syntax))
@ -8,6 +9,7 @@
(provide (rename-out [module-begin #%module-begin])
(except-out (all-from-out scheme/base) #%module-begin)
(all-from-out scheme/unit)
(all-from-out scheme/contract)
(for-syntax (all-from-out scheme/base)))
(define-for-syntax (make-name s)

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

@ -619,7 +619,7 @@
,@(navigation d ri #t)
,@(render-part d ri)
,@(navigation d ri #f)))
(div ([id "langindicator"]) nbsp)))))))))
(div ([id "contextindicator"]) nbsp)))))))))
(define/private (part-parent d ri)
(collected-info-parent (part-collected-info d ri)))

8
collects/scribble/lp-include.ss
View File

@ -7,14 +7,14 @@
(provide lp-include)
(define-syntax (module stx)
(syntax-case stx ()
(syntax-case stx (#%module-begin)
[(module name base (#%module-begin body ...))
#'(begin body ...)]
[(module name base body ...)
(begin
#'(begin body ...))]))
(raise-syntax-error #f "missing #%module-begin" stx)]))
(define-syntax (lp-include stx)
(syntax-case stx ()
[(_ name)
(with-syntax ([there (datum->syntax stx 'there)])
#'(include-at/relative-to here there name))]))

111
collects/scribble/scribble-common.js
View File

@ -1,5 +1,56 @@
// Common functionality for PLT documentation pages
// Page Parameters ------------------------------------------------------------
var page_query_string =
(location.href.search(/\?([^#]+)(?:#|$)/) >= 0) && RegExp.$1;
var page_args =
((function(){
if (!page_query_string) return [];
var args = page_query_string.split(/[&;]/);
for (var i=0; i<args.length; i++) {
var a = args[i];
var p = a.indexOf('=');
if (p >= 0) args[i] = [a.substring(0,p), a.substring(p+1)];
else args[i] = [a, false];
}
return args;
})());
function GetPageArg(key, def) {
for (var i=0; i<page_args.length; i++)
if (page_args[i][0] == key) return unescape(page_args[i][1]);
return def;
}
function MergePageArgsIntoLink(a) {
if (page_args.length == 0 ||
(!a.attributes["pltdoc"]) || (a.attributes["pltdoc"].value == ""))
return;
a.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
if (RegExp.$2.length == 0) {
a.href = RegExp.$1 + "?" + page_query_string + RegExp.$3;
} else {
// need to merge here, precedence to arguments that exist in `a'
var i, j;
var prefix = RegExp.$1, str = RegExp.$2, suffix = RegExp.$3;
var args = str.split(/[&;]/);
for (i=0; i<args.length; i++) {
j = args[i].indexOf('=');
if (j) args[i] = args[i].substring(0,j);
}
var additions = "";
for (i=0; i<page_args.length; i++) {
var exists = false;
for (j=0; j<args.length; j++)
if (args[j] == page_args[i][0]) { exists = true; break; }
if (!exists) str += "&" + page_args[i][0] + "=" + page_args[i][1];
}
a.href = prefix + "?" + str + suffix;
}
}
// Cookies --------------------------------------------------------------------
function GetCookie(key, def) {
@ -38,38 +89,6 @@ function GotoPLTRoot(ver, relative) {
return false;
}
// URL Parameters -------------------------------------------------------------
// In the following functions, the `name' argument is assumed to be simple in
// that it doesn't contain anything that isn't plain text in a regexp. (This
// is because JS doesn't have a `regexp-quote', easy to hack but not needed
// here). Also, the output value from the Get functions and the input value to
// the Set functions is decoded/encoded. Note that `SetArgInURL' mutates the
// string in the url object.
function GetArgFromString(str, name) {
var rx = new RegExp("(?:^|[;&])"+name+"=([^&;]*)(?:[;&]|$)");
return rx.test(str) && unescape(RegExp.$1);
}
function SetArgInString(str, name, val) {
val = escape(val);
if (str.length == 0) return name + "=" + val;
var rx = new RegExp("^((?:|.*[;&])"+name+"=)(?:[^&;]*)([;&].*|)$");
if (rx.test(str)) return RegExp.$1 + val + RegExp.$2;
else return name + "=" + val + "&" + str;
}
function GetArgFromURL(url, name) {
if (!url.href.search(/\?([^#]*)(?:#|$)/)) return false;
return GetArgFromString(RegExp.$1, name);
}
function SetArgInURL(url, name, val) { // note: mutates the string
url.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
url.href = RegExp.$1 + "?" + SetArgInString(RegExp.$2,name,val) + RegExp.$3;
}
// Utilities ------------------------------------------------------------------
normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/];
@ -91,7 +110,9 @@ function DoSearchKey(event, field, ver, top_path) {
if (event && event.keyCode == 13) {
var u = GetCookie("PLT_Root."+ver, null);
if (u == null) u = top_path; // default: go to the top path
location = u + "search/index.html" + "?q=" + escape(val);
u += "search/index.html?q=" + escape(val);
if (page_query_string) u += "&" + page_query_string;
location = u;
return false;
}
return true;
@ -115,23 +136,13 @@ window.onload = function() {
for (var i=0; i<on_load_funcs.length; i++) on_load_funcs[i]();
};
var cur_plt_lang = GetArgFromURL(location,"lang");
function PropagateLangInLink(a) {
// the attribute's value doesn't matter
if (cur_plt_lang
&& a.attributes["pltdoc"] && a.attributes["pltdoc"].value != ""
&& !GetArgFromURL(a,"lang"))
SetArgInURL(a, "lang", cur_plt_lang);
}
AddOnLoad(function(){
if (!cur_plt_lang) return;
var indicator = document.getElementById("langindicator");
if (indicator) {
indicator.innerHTML = cur_plt_lang;
indicator.style.display = "block";
}
var links = document.getElementsByTagName("a");
for (var i=0; i<links.length; i++) PropagateLangInLink(links[i]);
for (var i=0; i<links.length; i++) MergePageArgsIntoLink(links[i]);
var label = GetPageArg("ctxtname",false);
if (!label) return;
var indicator = document.getElementById("contextindicator");
if (!indicator) return;
indicator.innerHTML = label;
indicator.style.display = "block";
});

2
collects/scribble/scribble.css
View File

@ -119,7 +119,7 @@ table td {
vertical-align: middle;
}
#langindicator {
#contextindicator {
position: fixed;
background-color: #c6f;
color: #000;

9
collects/scribblings/foreign/types.scrbl
View File

@ -470,6 +470,15 @@ form, only the input @scheme[type-expr]s and the output @scheme[type-expr] are
specified, and each types is a simple expression, which creates a
straightforward function type.
For instance,
@schemeblock[
(_fun _int _string -> _int)
]
specifies a function that receives an integer and a
string, and returns an integer.
In its full form, the @scheme[_fun] syntax provides an IDL-like
language that can be used to create a wrapper function around the
primitive foreign function. These wrappers can implement complex

147
collects/scribblings/futures/futures.scrbl
View File

@ -7,35 +7,158 @@
@(require scribble/manual
scribble/urls
scribble/struct
(for-label scheme/base
(for-label scheme
scheme/base
scheme/contract
scheme/future))
@; ----------------------------------------------------------------------
PLT's parallel-future support is only enabled if you pass
@DFlag{enable-futures} to @exec{configure} when you build PLT (and
that build currently only works with @exec{mzscheme}, not with
@exec{mred}). When parallel-future support is not enabled,
@scheme[future] just remembers the given thunk to call sequentially
on a later @scheme[touch].
The PLT futures API enables the development of parallel programs which
take advantage of machines with multiple processors, cores, or
hardware threads.
@defmodule[scheme/future]{}
@defproc[(future [thunk (-> any)]) future?]{
Starts running @scheme[thunk] in parallel.
Starts running @scheme[thunk] in parallel. The @scheme[future]
procedure returns immediately with a future descriptor value.
}
@defproc[(touch [f future?]) any]{
Returns the value computed in the future @scheme[f], blocking
to let it complete if it hasn't yet completed.
Returns the value computed in the future @scheme[f], blocking until
the future completes (if it has not already completed).
}
@defproc[(future? [x any/c]) boolean?]{
Returns @scheme[#t] if @scheme[x] is a future.
Returns @scheme[#t] if @scheme[x] is a future.
}
@defproc[(processor-count) exact-positive-integer?]{
Returns the number of processors available on the current system.
Returns the number of processors/cores/hardware threads available on
the current system.
}
@section[#:tag "besteffortpar"]{Best-Effort Parallelism}
The @scheme[future] API represents a best-effort attempt to execute an
arbitrary segment of code in parallel. When designing programs and
algorithms which leverage @scheme[future] for parallel speedup, there
are a number of performance considerations to be aware of.
Futures are designed to accommodate the fact that many low-level
functions provided by the MzScheme virtual machine are not reentrant.
Thus, a future will execute its work in parallel until it detects an
attempt to perform an ``unsafe'' operation (e.g. invoking a
non-reentrant function). When such an operation is detected, the
future will block until @scheme[touch]ed, upon which the remainder of
its work will be done sequentially with respect to the touching
thread (in this case, ``thread'' refers to an OS thread).
To guarantee that unsafe operations never execute simultaneously, only
the initial OS thread used to start the MzScheme virtual machine (the
``runtime thread'') is allowed to execute them. If a parallel future
detects an attempted unsafe operation, it will signal the runtime
thread that pending unsafe work is available, then block, waiting for
the runtime thread to complete it. Note that as mentioned above, the
runtime thread will not attempt to do this work until the future is
explicitly touched. Also note that calls to @scheme[future] and
@scheme[touch] are themselves considered unsafe operations.
Consider the following contrived example:
@schemeblock[
(define (add-in-parallel a b)
(let ([f (future (lambda () (+ a b)))])
(touch f)))
(add-in-parallel 4 8)
]
The output of this program is, as expected:
@verbatim|{
12
}|
Now suppose we add a print message to our function for debugging purposes:
@schemeblock[
(define (add-in-parallel a b)
(let ([f (future
(lambda ()
(begin
(printf "Adding ~a and ~a together!~n" a b)
(+ a b))))])
(printf "About to touch my future...~n")
(touch f)))
(add-in-parallel 4 8)
]
Though this program still produces the same output, no work is being
done in parallel. Because @scheme[printf] is considered an unsafe
operation, f will block, and the print invocation (along with the
subsequent add) will not be performed until the @scheme[touch] call.
@section[#:tag "logging"]{How Do I Keep Those Cores Busy?}
It is not always obvious when or where unsafe operations may
be causing unacceptable performance degradation in parallel programs.
A a general guideline, any primitive that is inlined will run in parallel.
For example, fixnum and flonum addition do run in parallel,
but not bignum or rational addition. Similarly, vector operations are
generally safe, but not continuation operations. Also, allocation can run
in parallel, as long as only a little bit of allocation happens. Once a significant
amount of allocation happens, a parallel thread has to rendez-vous with the
runtime thread to get new, local memory.
To help tell what is happening in your program, the parallel threads
logs all of the points at which it has to synchronize
with the runtime thread.
For example, running the code in the previous
example in the debug log level produces the following output:
@verbatim|{
About to touch my future...
future: 0 waiting for runtime at 1259702453747.720947: printf
Adding 4 and 8 together!
12
}|
The message indicates which future blocked, the time it blocked and
the primitive operation that caused it to block.
To be sure we are not merely seeing the effects of a race condition in
this example, we can force the main thread to @scheme[sleep] for an
unreasonable amount of time:
@schemeblock[
(define (add-in-parallel a b)
(let ([f (future
(lambda ()
(begin
(printf "Adding ~a and ~a together!~n" a b)
(+ a b))))])
(sleep 10.0)
(printf "About to touch my future...~n")
(touch f)))
(add-in-parallel 4 8)
]
@verbatim|{
About to touch my future...
future: 0 waiting for runtime at 1259702453747.720947: printf
Adding 4 and 8 together!
12
}|
@section[#:tag "compiling"]{Enabling Futures in MzScheme Builds}
PLT's parallel-future support is only enabled if you pass
@DFlag{enable-futures} to @exec{configure} when you build PLT (and
that build currently only works with @exec{mzscheme}, not with
@exec{mred}). When parallel-future support is not enabled,
@scheme[future] just remembers the given thunk to call sequentially on
a later @scheme[touch].

4
collects/scribblings/gui/text-class.scrbl
View File

@ -1735,7 +1735,7 @@ If @scheme[end] is not @scheme['same] and not the same as @scheme[start],
When the specified range cannot fit in the visible area, @scheme[bias]
indicates which end of the range to display. When @scheme[bias] is
@scheme['same], then the start of the range is displayed. When
@scheme['start], then the start of the range is displayed. When
@scheme[bias] is @scheme['end], then the end of the range is
displayed. Otherwise, @scheme[bias] must be @scheme['none].
@ -1747,7 +1747,7 @@ If the editor is scrolled, then the editor is redrawn and the return
scroll-editor-to].
Scrolling is disallowed when the editor is internally locked for
reflowing (see also @|lockdiscuss|).
reflowing (see also @|lockdiscuss|).
The system may scroll the editor without calling this method. For
example, a canvas displaying an editor might scroll the editor to

6
collects/scribblings/guide/performance.scrbl
View File

@ -253,9 +253,9 @@ machine's instruction to add the numbers (and check for overflow). If
the two numbers are not fixnums, then the next check whether whether
both are flonums; in that case, the machine's floating-point
operations are used directly. For functions that take any number of
arguments, such as @scheme[+], inlining is applied only for the
two-argument case (except for @scheme[-], whose one-argument case is
also inlined).
arguments, such as @scheme[+], inlining works for two or more
arguments (except for @scheme[-], whose one-argument case is also
inlined) when the arguments are either all fixnums or all flonums.
Flonums are @defterm{boxed}, which means that memory is allocated to
hold every result of a flonum computation. Fortunately, the

5
collects/scribblings/inside/custodians.scrbl
View File

@ -36,7 +36,6 @@ Creates a new custodian as a subordinate of @var{m}. If @var{m} is
Places the value @var{o} into the management of the custodian
@var{m}. If @var{m} is @cpp{NULL}, the current custodian is used.
The @var{f} function is called by the custodian if it is ever asked to
``shutdown'' its values; @var{o} and @var{data} are passed on to
@var{f}, which has the type
@ -52,6 +51,10 @@ be remembered until either the custodian shuts it down or
zero, the value is allowed to be garbaged collected (and automatically
removed from the custodian).
Independent of whether @var{strong} is zero, the value @var{o} is
initially weakly held. A value associated with a custodian can
therefore be finalized via will executors.
The return value from @cpp{scheme_add_managed} can be used to refer
to the value's custodian later in a call to
@cpp{scheme_remove_managed}. A value can be registered with at

7
collects/scribblings/inside/hooks.scrbl
View File

@ -57,6 +57,13 @@ Sets the path to be returned by @scheme[(find-system-path
'collects-dir)].}
@function[(void scheme_set_addon_path
[Scheme_Object* path])]{
Sets the path to be returned by @scheme[(find-system-path
'addon-dir)].}
@function[(void scheme_init_collection_paths_post
[Scheme_Env* env]
[Scheme_Object* pre_extra_paths]

10
collects/scribblings/main/private/search.js
View File

@ -226,7 +226,7 @@ function InitializeSearch() {
result_links.push(n);
AdjustResultsNum();
// get search string
var init_q = GetArgFromURL(location,"q");
var init_q = GetPageArg("q",false);
if (init_q && init_q != "") query.value = init_q;
ContextFilter();
DoSearch();
@ -599,7 +599,7 @@ function UpdateResults() {
if (first_search_result < 0 ||
first_search_result >= search_results.length)
first_search_result = 0;
var link_lang = (cur_plt_lang && ("?lang="+escape(cur_plt_lang)));
var link_args = (page_query_string && ("?"+page_query_string));
for (var i=0; i<result_links.length; i++) {
var n = i + first_search_result;
if (n < search_results.length) {
@ -639,12 +639,12 @@ function UpdateResults() {
if (note)
note = '&nbsp;&nbsp;<span class="smaller">' + note + '</span>';
var href = UncompactUrl(res[1]);
if (link_lang) {
if (link_args) {
var hash = href.indexOf("#");
if (hash >= 0)
href = href.substring(0,hash) + link_lang + href.substring(hash);
href = href.substring(0,hash) + link_args + href.substring(hash);
else
href = href + link_lang;
href = href + link_args;
}
result_links[i].innerHTML =
'<a href="' + href + '" class="indexlink" tabIndex="2">'

25
collects/scribblings/reference/collects.scrbl
View File

@ -33,11 +33,26 @@ scheme
....
]
In general, the @scheme[_rel-string] in @scheme[(lib _rel-string)]
consists of one or more path elements that name collections, and then
a final path element that names a library file; the path elements are
separated by @litchar{/}. If the final element has no file suffix,
then @litchar{/main.ss} is implicitly appended to the path.
This example is more compactly and more commonly written as
@schememod[
scheme
(require setup/getinfo
games/cards/cards)
....
]
When an identifier @scheme[_id] is used in a @scheme[require] form, it
is converted to @scheme[(lib _rel-string)] where @scheme[_rel-string]
is the string form of @scheme[_id].
A @scheme[_rel-string] in @scheme[(lib _rel-string)] consists of one
or more path elements that name collections, and then a final path
element that names a library file; the path elements are separated by
@litchar{/}. If @scheme[_rel-string] contains no @litchar{/}s, then
then @litchar{/main.ss} is implicitly appended to the path. If
@scheme[_rel-string] contains @litchar{/} but does not end with a file
suffix, then @litchar{.ss} is implicitly appended to the path.
The translation of a @scheme[planet] or @scheme[lib] path to a
@scheme[module] declaration is determined by the @tech{module name

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

@ -1196,8 +1196,8 @@ This property should only be present if the contract is a flat contract. In the
@mz-examples[#:eval (contract-eval)
(flat-pred? (-> integer? integer?))
(let ([c (between/c 1 10)]
[pred ((flat-get c) c)])
(let* ([c (between/c 1 10)]
[pred ((flat-get c) c)])
(list (pred 9)
(pred 11)))]
}

45
collects/scribblings/reference/exns.scrbl
View File

@ -40,8 +40,20 @@ multiple returns/escapes are impossible. All exceptions raised by
Breaks are disabled from the time the exception is raised until the
exception handler obtains control, and the handler itself is
@scheme[parameterize-break]ed to disable breaks initially; see
@secref["breakhandler"] for more information on breaks.}
@secref["breakhandler"] for more information on breaks.
@examples[
(with-handlers ([number? (lambda (n)
(+ n 5))])
(raise 18 #t))
(define-struct (my-exception exn:fail:user) ())
(with-handlers ([my-exception? (lambda (e)
#f)])
(+ 5 (raise (make-my-exception
"failed"
(current-continuation-marks)))))
(raise 'failed #t)
]}
@defproc*[([(error [sym symbol?]) any]
[(error [msg string?][v any/c] ...) any]
@ -72,7 +84,13 @@ ways:
]
In all cases, the constructed message string is passed to
@scheme[make-exn:fail], and the resulting exception is raised.}
@scheme[make-exn:fail], and the resulting exception is raised.
@examples[
(error 'failed)
(error "failed" 23 'pizza (list 1 2 3))
(error 'failed "~a failed because ~a" 'method-a "no argument supplied")
]}
@defproc*[([(raise-user-error [sym symbol?]) any]
[(raise-user-error [msg string?][v any/c] ...) any]
@ -83,7 +101,13 @@ Like @scheme[error], but constructs an exception with
default @tech{error display handler} does not show a ``stack trace'' for
@scheme[exn:fail:user] exceptions (see @secref["contmarks"]), so
@scheme[raise-user-error] should be used for errors that are intended
for end users.}
for end users.
@examples[
(raise-user-error 'failed)
(raise-user-error "failed" 23 'pizza (list 1 2 3))
(raise-user-error 'failed "~a failed because ~a" 'method-a "no argument supplied")
]}
@defproc*[([(raise-type-error [name symbol?][expected string?][v any/c]) any]
@ -102,7 +126,20 @@ In the second form, the bad argument is indicated by an index
arguments @scheme[v] are provided (in order). The resulting error
message names the bad argument and also lists the other arguments. If
@scheme[bad-pos] is not less than the number of @scheme[v]s, the
@exnraise[exn:fail:contract].}
@exnraise[exn:fail:contract].
@examples[
(define (feed-cow animal)
(if (not (eq? animal 'cow))
(raise-type-error 'feed-cow "cow" animal)
"fed the cow"))
(feed-cow 'turkey)
(define (feed-animals cow sheep goose cat)
(if (not (eq? goose 'goose))
(raise-type-error 'feed-animals "goose" 2 cow sheep goose cat)
"fed the animals"))
(feed-animals 'cow 'sheep 'dog 'cat)
]}
@defproc[(raise-mismatch-error [name symbol?][message string?][v any/c]) any]{

45
collects/scribblings/reference/filesystem.scrbl
View File

@ -80,10 +80,15 @@ by @scheme[kind], which must be one of the following:
]}
@item{@indexed-scheme['addon-dir] --- a directory for installing PLT Scheme
extensions. It's the same as @scheme['pref-dir], except under Mac OS
X, where it is @filepath{Library/PLT Scheme} in the user's home
directory. This directory might not exist.}
@item{@indexed-scheme['addon-dir] --- a directory for installing PLT
Scheme extensions. This directory is specified by the
@indexed-envvar{PLTADDONDIR} environment variable, and it can be
overridden by the @DFlag{addon} or @Flag{A} command-line flag. If no
environment variable or flag is specified, or if the value is not a
legal path name, then this directory defaults to
@filepath{Library/PLT Scheme} in the user's home directory under Mac
OS X and @scheme['pref-dir] otherwise. This directory might not
exist.}
@item{@indexed-scheme['doc-dir] --- the standard directory for
storing the current user's documents. Under Unix, it's the same as
@ -593,17 +598,6 @@ Reads all characters from @scheme[path] and returns them as a
@tech{byte string}. The @scheme[mode-flag] argument is the same as
for @scheme[open-input-file].}
@defproc[(file->lines [path path-string?]
[#:mode mode-flag (or/c 'binary 'text) 'binary]
[#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
bytes?]{
Read all characters from @scheme[path], breaking them into lines. The
@scheme[line-mode] argument is the same as the second argument to
@scheme[read-line], but the default is @scheme['any] instead of
@scheme['linefeed]. The @scheme[mode-flag] argument is the same as for
@scheme[open-input-file].}
@defproc[(file->value [path path-string?]
[#:mode mode-flag (or/c 'binary 'text) 'binary])
bytes?]{
@ -612,10 +606,29 @@ Reads a single S-expression from @scheme[path] using @scheme[read].
The @scheme[mode-flag] argument is the same as for
@scheme[open-input-file].}
@defproc[(file->list [path path-string?]
[proc (input-port? . -> . any/c) read]
[#:mode mode-flag (or/c 'binary 'text) 'binary])
(listof any/c)]{
Repeatedly calls @scheme[proc] to consume the contents of
@scheme[path], until @scheme[eof] is produced. The @scheme[mode-flag]
argument is the same as for @scheme[open-input-file]. }
@defproc[(file->lines [path path-string?]
[#:mode mode-flag (or/c 'binary 'text) 'binary]
[#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
(listof string?)]{
Read all characters from @scheme[path], breaking them into lines. The
@scheme[line-mode] argument is the same as the second argument to
@scheme[read-line], but the default is @scheme['any] instead of
@scheme['linefeed]. The @scheme[mode-flag] argument is the same as for
@scheme[open-input-file].}
@defproc[(file->bytes-lines [path path-string?]
[#:mode mode-flag (or/c 'binary 'text) 'binary]
[#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
bytes?]{
(listof bytes?)]{
Like @scheme[file->lines], but reading bytes and collecting them into
lines like @scheme[read-bytes-line].}

4
collects/scribblings/reference/mz.ss
View File

@ -128,6 +128,6 @@
(define-syntax speed
(syntax-rules ()
[(_ id what)
(t "An" (scheme id) "application can provide better performance for"
(t "An " (scheme id) " application can provide better performance for "
(elem what)
"iteration when it appears directly in a" (scheme for) "clause.")])))
" iteration when it appears directly in a " (scheme for) " clause.")])))

60
collects/scribblings/reference/numbers.scrbl
View File

@ -849,6 +849,58 @@ Returns @scheme[#t] if the native encoding of numbers is big-endian
for the machine running Scheme, @scheme[#f] if the native encoding
is little-endian.}
@; ------------------------------------------------------------------------
@section{Inexact-Real Vectors}
A @deftech{flvector} is like a @tech{vector}, but it holds only
inexact real numbers. This representation can be more compact, and
unsafe operations on @tech{flvector}s (see
@schememodname[scheme/unsafe/ops]) can execute more efficiently than
unsafe operations on @tech{vectors} of inexact reals.
An f64vector as provided by @schememodname[scheme/foreign] stores the
same kinds of values as an @tech{flvector}, but with extra
indirections that make f64vectors more convenient for working with
foreign libraries. The lack of indirections make unsafe
@tech{flvector} access more efficient.
@defproc[(flvector? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @tech{flvector}, @scheme[#f] otherwise.}
@defproc[(flvector [x inexact-real?] ...) flvector?]{
Creates a @tech{flvector} containing the given inexact real numbers.}
@defproc[(make-flvector [size exact-nonnegative-integer?]
[x inexact-real? 0.0])
flvector?]{
Creates a @tech{flvector} with @scheme[size] elements, where every
slot in the @tech{flvector} is filled with @scheme[x].}
@defproc[(flvector-length [vec flvector?]) exact-nonnegative-integer?]{
Returns the length of @scheme[vec] (i.e., the number of slots in the
@tech{flvector}).}
@defproc[(flvector-ref [vec flvector?] [pos exact-nonnegative-integer?])
inexact-real?]{
Returns the inexact real number in slot @scheme[pos] of
@scheme[vec]. The first slot is position @scheme[0], and the last slot
is one less than @scheme[(flvector-length vec)].}
@defproc[(flvector-set! [vec flvector?] [pos exact-nonnegative-integer?]
[x inexact-real?])
inexact-real?]{
Sets the inexact real number in slot @scheme[pos] of @scheme[vec]. The
first slot is position @scheme[0], and the last slot is one less than
@scheme[(flvector-length vec)].}
@; ------------------------------------------------------------------------
@section{Extra Constants and Functions}
@ -901,13 +953,15 @@ Returns the hyperbolic tangent of @scheme[z].}
Computes the greatest exact integer @scheme[m] such that:
@schemeblock[(<= (expt 10 m)
(inexact->exact r))]
Hence also
Hence also:
@schemeblock[(< (inexact->exact r)
(expt 10 (add1 m)))].
(expt 10 (add1 m)))]
@mz-examples[#:eval math-eval
(order-of-magnitude 999)
(order-of-magnitude 1000)]
(order-of-magnitude 1000)
(order-of-magnitude 1/100)
(order-of-magnitude 1/101)]
}
@; ----------------------------------------------------------------------

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

@ -878,12 +878,12 @@ without building the intermediate list.
]}
@defproc[(count [proc procedure?] [lst list?] ...+)
list?]{
exact-nonnegative-integer?]{
Returns @scheme[(length (filter proc lst ...))], but
without building the intermediate list.
Returns @scheme[(length (filter proc lst ...))], but without building
the intermediate list.
@mz-examples[
@mz-examples[#:eval list-eval
(count positive? '(1 -1 2 3 -2 5))
]}

18
collects/scribblings/reference/procedures.scrbl
View File

@ -53,8 +53,18 @@ result is @scheme[values].
Returns a procedure that is like @scheme[proc], except that its name
as returned by @scheme[object-name] (and as printed for debugging) is
@scheme[name].}
@scheme[name].
The given @scheme[name] is used for printing an error message if the
resulting procedure is applied to the wrong number of arguments. In
addition, if @scheme[proc] is an @tech{accessor} or @tech{mutator}
produced by @scheme[define-struct],
@scheme[make-struct-field-accessor], or
@scheme[make-struct-field-mutator], the resulting procedure also uses
@scheme[name] when its (first) argument has the wrong type. More
typically, however, @scheme[name] is not used for reporting errors,
since the procedure name is typically hard-wired into an internal
check.}
@; ----------------------------------------
@section{Keywords and Arity}
@ -243,7 +253,7 @@ See also @scheme[procedure-arity?].}
@defthing[prop:procedure struct-type-property?]{
A @tech{structure type property} to indentify structure types whose
A @tech{structure type property} to identify structure types whose
instances can be applied as procedures. In particular, when
@scheme[procedure?] is applied to the instance, the result will be
@scheme[#t], and when an instance is used in the function position of
@ -441,8 +451,8 @@ primitive closure rather than a simple primitive procedure,
Returns the arity of the result of the primitive procedure
@scheme[prim] (as opposed to the procedure's input arity as returned
by @scheme[arity]). For most primitives, this procedure returns
@scheme[1], since most primitives return a single value when
by @scheme[procedure-arity]). For most primitives, this procedure
returns @scheme[1], since most primitives return a single value when
applied.}
@; ----------------------------------------

9
collects/scribblings/reference/stx-trans.scrbl
View File

@ -63,7 +63,7 @@ is identified by the @scheme[prop:set!-transformer] property of
@defthing[prop:set!-transformer struct-type-property?]{
A @tech{structure type property} to indentify structure types that act
A @tech{structure type property} to identify structure types that act
as @tech{assignment transformers} like the ones created by
@scheme[make-set!-transformer].
@ -133,7 +133,7 @@ create @scheme[transformer] or as indicated by a
@defthing[prop:rename-transformer struct-type-property?]{
A @tech{structure type property} to indentify structure types that act
A @tech{structure type property} to identify structure types that act
as @tech{rename transformers} like the ones created by
@scheme[make-rename-transformer].
@ -576,8 +576,9 @@ exports of the module.
Returns @scheme[id-stx] if no binding in the current expansion context
shadows @scheme[id-stx] (ignoring unsealed @tech{internal-definition
contexts}), if @scheme[id-stx] has no module bindings in its lexical
information, and if the current expansion context is not a
contexts} and identifiers that had the @indexed-scheme['unshadowable]
@tech{syntax property}), if @scheme[id-stx] has no module bindings in
its lexical information, and if the current expansion context is not a
@tech{module context}.
If a binding of @scheme[inner-identifier] shadows @scheme[id-stx], the

27
collects/scribblings/reference/unsafe.scrbl
View File

@ -1,6 +1,10 @@
#lang scribble/doc
@(require "mz.ss"
(for-label scheme/unsafe/ops))
(for-label scheme/unsafe/ops
(only-in scheme/foreign
f64vector?
f64vector-ref
f64vector-set!)))
@title[#:tag "unsafe"]{Unsafe Operations}
@ -165,6 +169,27 @@ Unsafe versions of @scheme[bytes-length], @scheme[bytes-ref], and
fixnum).}
@deftogether[(
@defproc[(unsafe-flvector-length [v flvector?]) fixnum?]
@defproc[(unsafe-flvector-ref [v flvector?][k fixnum?]) any/c]
@defproc[(unsafe-flvector-set! [v flvector?][k fixnum?][x inexact-real?]) void?]
)]{
Unsafe versions of @scheme[flvector-length], @scheme[flvector-ref], and
@scheme[flvector-set!]. A @tech{flvector}'s size can never be larger than a
@tech{fixnum} (so even @scheme[flvector-length] always returns a
fixnum).}
@deftogether[(
@defproc[(unsafe-f64vector-ref [vec f64vector?][k fixnum?]) inexact-real?]
@defproc[(unsafe-f64vector-set! [vec f64vector?][k fixnum?][n inexact-real?]) void?]
)]{
Unsafe versions of @scheme[f64vector-ref] and
@scheme[f64vector-set!].}
@deftogether[(
@defproc[(unsafe-struct-ref [v any/c][k fixnum?]) any/c]
@defproc[(unsafe-struct-set! [v any/c][k fixnum?][val any/c]) void?]

22
collects/scribblings/reference/vectors.scrbl
View File

@ -184,7 +184,7 @@ Applies @scheme[proc] to the elements of the @scheme[vec]s from the
v
]}
@defproc[(vector-append [lst list?] ...) list?]{
@defproc[(vector-append [vec vector?] ...) vector?]{
Creates a fresh vector that contains all
of the elements of the given vectors in order.
@ -194,19 +194,19 @@ of the elements of the given vectors in order.
}
@defproc[(vector-take [vec vector?] [pos exact-nonnegative-integer?]) list?]{
@defproc[(vector-take [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
Returns a fresh vector whose elements are the first @scheme[pos] elements of
@scheme[vec]. If @scheme[vec] has fewer than
@scheme[pos] elements, the @exnraise[exn:fail:contract].
@scheme[pos] elements, then the @exnraise[exn:fail:contract].
@mz-examples[#:eval vec-eval
(vector-take #(1 2 3 4) 2)
]}
@defproc[(vector-take-right [vec vector?] [pos exact-nonnegative-integer?]) list?]{
@defproc[(vector-take-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
Returns a fresh vector whose elements are the last @scheme[pos] elements of
@scheme[vec]. If @scheme[vec] has fewer than
@scheme[pos] elements, the @exnraise[exn:fail:contract].
@scheme[pos] elements, then the @exnraise[exn:fail:contract].
@mz-examples[#:eval vec-eval
(vector-take-right #(1 2 3 4) 2)
@ -215,7 +215,7 @@ Returns a fresh vector whose elements are the last @scheme[pos] elements of
@defproc[(vector-drop [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
Returns a fresh vector whose elements are the elements of @scheme[vec]
after the first @scheme[pos] elements. If @scheme[vec] has fewer
than @scheme[pos] elements, the @exnraise[exn:fail:contract].
than @scheme[pos] elements, then the @exnraise[exn:fail:contract].
@mz-examples[#:eval vec-eval
(vector-drop #(1 2 3 4) 2)
@ -224,7 +224,7 @@ Returns a fresh vector whose elements are the elements of @scheme[vec]
@defproc[(vector-drop-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
Returns a fresh vector whose elements are the elements of @scheme[vec]
before the first @scheme[pos] elements. If @scheme[vec] has fewer
than @scheme[pos] elements, the @exnraise[exn:fail:contract].
than @scheme[pos] elements, then the @exnraise[exn:fail:contract].
@mz-examples[#:eval vec-eval
(vector-drop-right #(1 2 3 4) 2)
@ -288,11 +288,11 @@ returns @scheme[#f].
]}
@defproc[(vector-count [proc procedure?] [lst list?] ...+)
list?]{
@defproc[(vector-count [proc procedure?] [vec vector?] ...+)
exact-nonnegative-integer?]{
Returns @scheme[(vector-length (vector-filter proc lst ...))], but
without building the intermediate list.
Returns the number of elements of the @scheme[vec ...] (taken in
parallel) on which @scheme[proc] does not evaluate to @scheme[#f].
@mz-examples[#:eval vec-eval
(vector-count even? #(1 2 3 4 5))

5
collects/scribblings/tools/unit.scrbl
View File

@ -574,6 +574,11 @@ Shows the interactions window
Returns the currently active tab.
}
@defmethod[(open-in-new-tab [filename (or/c path-string? #f)]) void?]{
Opens a new tab in this frame. If @scheme[filename] is a @scheme[path-string?],
It loads that file in the definitions window of the new tab.
}
@defmethod[#:mode public-final (close-current-tab) void?]{
Closes the current tab, making some other tab visible.

4
collects/srfi/19/time.ss
View File

@ -390,13 +390,13 @@
(define (time>=? time1 time2)
(tm:time-compare-check time1 time2 'time>=?)
(or (>= (time-second time1) (time-second time2))
(or (> (time-second time1) (time-second time2))
(and (= (time-second time1) (time-second time2))
(>= (time-nanosecond time1) (time-nanosecond time2)))))
(define (time<=? time1 time2)
(tm:time-compare-check time1 time2 'time<=?)
(or (<= (time-second time1) (time-second time2))
(or (< (time-second time1) (time-second time2))
(and (= (time-second time1) (time-second time2))
(<= (time-nanosecond time1) (time-nanosecond time2)))))

260
collects/syntax/module-reader.ss
View File

@ -21,41 +21,42 @@
(if (not (and (pair? body)
(pair? (cdr body))
(keyword? (syntax-e (car body)))))
(datum->syntax stx body stx)
(let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
(case k*
[(kwd) (if var
(err (format "got two ~s keywords" k*) k)
(begin (set! var v) (loop (cddr body))))]
...
[else (err "got an unknown keyword" (car body))])))))
(datum->syntax stx body stx)
(let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
(case k*
[(kwd) (if var
(err (format "got two ~s keywords" k*) k)
(begin (set! var v) (loop (cddr body))))]
...
[else (err "got an unknown keyword" (car body))])))))
checks ...
(unless var (set! var default)) ...))
(define <lang-id> (datum->syntax stx 'language-module stx))
(define <data-id> (datum->syntax stx 'language-data stx))
(define (construct-reader lang body)
(keywords body
[#:language ~lang lang]
[#:read ~read #'read]
[#:read-syntax ~read-syntax #'read-syntax]
[#:wrapper1 ~wrapper1 #'#f]
[#:wrapper2 ~wrapper2 #'#f]
[#:whole-body-readers? ~whole-body-readers? #'#f]
[#:info ~info #'#f]
[(when (equal? (and lang #t) (and ~lang #t))
(err (string-append
"must specify either a module language, or #:language"
(if (and lang ~lang) ", not both" ""))))
(unless (equal? (and ~read #t) (and ~read-syntax #t))
(err "must specify either both #:read and #:read-syntax, or none"))
(when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
(err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
;; FIXME: a lot of the generated code is constant and should be lifted
;; out of the template:
[#:language ~lang lang]
[#:read ~read #'read]
[#:read-syntax ~read-syntax #'read-syntax]
[#:wrapper1 ~wrapper1 #'#f]
[#:wrapper2 ~wrapper2 #'#f]
[#:whole-body-readers? ~whole-body-readers? #'#f]
[#:info ~info #'#f]
[(when (equal? (and lang #t) (and ~lang #t))
(err (string-append
"must specify either a module language, or #:language"
(if (and lang ~lang) ", not both" ""))))
(unless (equal? (and ~read #t) (and ~read-syntax #t))
(err "must specify either both #:read and #:read-syntax, or none"))
(when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
(err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
;; FIXME: some generated code is constant and should be lifted out of the
;; template:
(quasisyntax/loc stx
(#%module-begin
#,@body
(#%provide (rename lang:read read) (rename lang:read-syntax read-syntax)
(#%provide (rename lang:read read)
(rename lang:read-syntax read-syntax)
read-properties get-info-getter get-info)
(define (lang:read in modpath line col pos)
(wrap-internal/wrapper #f #f in modpath line col pos))
@ -66,49 +67,27 @@
[lang (car props)] [#,<lang-id> lang] ;\ visible in
[data (cadr props)] [#,<data-id> data] ;/ user-code
[read (if stx?
(let ([rd #,~read-syntax]) (lambda (in) (rd src in)))
#,~read)]
(let ([rd #,~read-syntax])
(lambda (in) (rd src in)))
#,~read)]
[w1 #,~wrapper1]
[w2 #,~wrapper2]
[whole? #,~whole-body-readers?]
[rd (lambda (in) (wrap-internal (if (and (not stx?) (syntax? lang))
(syntax->datum lang)
lang)
in read whole? w1 stx?
modpath src line col pos))]
[rd (lambda (in)
(wrap-internal (if (and (not stx?) (syntax? lang))
(syntax->datum lang)
lang)
in read whole? w1 stx?
modpath src line col pos))]
[r (cond [(not w2) (rd in)]
[(ar? w2 3) (w2 in rd stx?)]
[else (w2 in rd)])])
(if stx?
(syntax-property r 'module-language
(vector (syntax->datum modpath) 'get-info-getter
props))
r)))
(define lang*
(let ([lang #,~lang])
(if (not (procedure? lang))
(list lang #f)
(cond [(ar? lang 5) lang]
[(ar? lang 1) (lambda (in . _) (lang in))]
[(ar? lang 0) (lambda _ (lang))]
[else (raise-type-error
'syntax/module-reader
"language+reader procedure of 5, 1, or 0 arguments"
lang)]))))
(define (read-properties in modpath line col pos)
(if (not (procedure? lang*))
lang*
(call-with-values
(lambda () (parameterize ([current-input-port in])
(lang* in modpath line col pos)))
(lambda xs
(case (length xs)
[(2) xs] [(1) (list (car xs) #f)]
[else (error 'syntax/module-reader
"wrong number of results from ~a, ~a ~e"
"the #:language function"
"expected 1 or 2 values, got"
(length xs))])))))
(syntax-property r
'module-language
(vector (syntax->datum modpath) 'get-info-getter props))
r)))
(define read-properties (lang->read-properties #,~lang))
(define (get-info in modpath line col pos)
(get-info-getter (read-properties in modpath line col pos)))
(define (get-info-getter props)
@ -124,14 +103,14 @@
[#,<data-id> data] ;/ user-code
[info #,~info])
(if (or (not info) (and (procedure? info) (ar? info 3)))
info
(raise-type-error 'syntax/module-reader
"info procedure of 3 arguments" info))))
info
(raise-type-error 'syntax/module-reader
"info procedure of 3 arguments" info))))
(define (language-info what defval)
(if info
(let ([r (info what defval default-info)])
(if (eq? r default-info) (default-info what defval) r))
(default-info what defval)))
(let ([r (info what defval default-info)])
(if (eq? r default-info) (default-info what defval) r))
(default-info what defval)))
language-info))))
(syntax-case stx ()
[(_ lang body ...)
@ -139,55 +118,104 @@
(construct-reader #''lang (syntax->list #'(body ...)))]
[(_ body ...) (construct-reader #f (syntax->list #'(body ...)))]))
;; turns the language specification (either a language or some flavor of a
;; function that returns a language and some properties) into a function that
;; returns (list <lang> <props>)
(define (lang->read-properties lang)
(define lang*
(cond [(not (procedure? lang)) (list lang #f)]
[(ar? lang 5) lang]
[(ar? lang 1) (lambda (in . _) (lang in))]
[(ar? lang 0) (lambda _ (lang))]
[else (raise-type-error
'syntax/module-reader
"language+reader procedure of 5, 1, or 0 arguments"
lang)]))
(define (read-properties in modpath line col pos)
(if (not (procedure? lang*))
lang*
(parameterize ([current-input-port in])
(call-with-values
(lambda () (lang* in modpath line col pos))
(lambda xs
(case (length xs)
[(2) xs] [(1) (list (car xs) #f)]
[else (error 'syntax/module-reader
"wrong number of results from ~a, ~a ~e"
"the #:language function"
"expected 1 or 2 values, got"
(length xs))]))))))
read-properties)
;; Since there are users that wrap with `#%module-begin' in their reader
;; or wrapper1 functions, we need to avoid double-wrapping. Having to do
;; this for #lang readers should be considered deprecated, and hopefully
;; one day we'll move to just doing it unilaterally (making this code throw
;; an error in that case before that's done).
;; This function takes "body" as a sequence of expressions (can be syntaxes
;; and/or sexprs) and returns a new body as a *single* expression that is
;; wrapped in a `#%module-begin' -- using the input if it was a single
;; pre-wrapped expression.
(define (wrap-module-begin body)
(let ([exprs (if (syntax? body) (syntax->list body) body)])
(if (and (pair? exprs) (null? (cdr exprs))
(let* ([x (car exprs)]
[x (if (syntax? x) (syntax-e x) x)]
[x (and (pair? x) (car x))]
[x (if (syntax? x) (syntax-e x) x)])
(eq? x '#%module-begin)))
(car exprs)
(cons '#%module-begin body))))
(define (wrap-internal lang port read whole? wrapper stx?
modpath src line col pos)
(let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)]
[body (lambda ()
(if whole?
(read port)
(let loop ([a null])
(let ([v (read port)])
(if (eof-object? v) (reverse a) (loop (cons v a)))))))]
(read port)
(let loop ([a null])
(let ([v (read port)])
(if (eof-object? v)
(reverse a)
(loop (cons v a)))))))]
[body (cond [(not wrapper) (body)]
[(ar? wrapper 2) (wrapper body stx?)]
[else (wrapper body)])]
[body (wrap-module-begin body)]
[all-loc (vector src line col pos
(let-values ([(l c p) (port-next-location port)])
(and p (- p pos))))]
[body (if (and stx? (not (syntax? body)))
(datum->syntax #f body all-loc)
body)]
[p-name (object-name port)]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol
(path->string (path-replace-suffix name #""))))
'page)]
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol
(path->string (path-replace-suffix name #""))))
'anonymous-module)]
[tag-src (lambda (v)
(if stx?
(datum->syntax
#f v (vector src line col pos
(- (or (syntax-position modpath) (add1 pos))
pos)))
v))]
[r `(,(tag-src 'module) ,(tag-src name) ,lang . ,body)])
(datum->syntax
#f v (vector src line col pos
(- (or (syntax-position modpath)
(add1 pos))
pos)))
v))]
[r `(,(tag-src 'module) ,(tag-src name) ,lang ,body)])
(if stx? (datum->syntax #f r all-loc) r)))
(define (wrap lang port read modpath src line col pos)
(wrap-internal lang port read #f #f #f modpath src line col pos))
(define (make-meta-reader self-sym module-path-desc spec->module-path
convert-read
convert-read-syntax
convert-get-info
#:read-spec [read-spec
(lambda (in)
(let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)])
(and spec
(let ([s (cadr spec)])
(if (equal? s "")
#f
s)))))])
(define (make-meta-reader
self-sym module-path-desc spec->module-path
convert-read
convert-read-syntax
convert-get-info
#:read-spec
[read-spec
(lambda (in)
(let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)])
(and spec (let ([s (cadr spec)])
(if (equal? s "") #f s)))))])
(define (get in export-sym src line col pos mk-fail-thunk)
(define (bad str eof?)
((if eof? raise-read-eof-error raise-read-error)
@ -198,35 +226,41 @@
(and pos pos2 (- pos2 pos)))))
(define spec (read-spec in))
(if (not spec)
(bad #f (eof-object? (peek-byte in)))
(let ([parsed-spec (spec->module-path spec)])
(if parsed-spec
(begin ((current-reader-guard) parsed-spec)
(dynamic-require parsed-spec export-sym (mk-fail-thunk spec)))
(bad spec #f)))))
(bad #f (eof-object? (peek-byte in)))
(let ([parsed-spec (spec->module-path spec)])
(if parsed-spec
(begin ((current-reader-guard) parsed-spec)
(dynamic-require parsed-spec export-sym
(mk-fail-thunk spec)))
(bad spec #f)))))
(define (-get-info inp mod line col pos)
(let ([r (get inp 'get-info (object-name inp) line col pos
(lambda (spec) (lambda () (lambda (inp mod line col pos)
(lambda (tag defval) defval)))))])
(lambda (spec)
(lambda ()
(lambda (inp mod line col pos)
(lambda (tag defval) defval)))))])
(convert-get-info (r inp mod line col pos))))
(define (read-fn in read-sym args src mod line col pos convert)
(let ([r (get in read-sym src #|mod|# line col pos
(lambda (spec)
(lambda ()
(error self-sym "cannot find reader for `#lang ~a ~a'"
(error read-sym "cannot find reader for `#lang ~a ~a'"
self-sym
spec))))])
(let ([r (convert r)])
(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)))))))
(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 (-read inp mod line col pos)
(read-fn inp 'read null (object-name inp) mod line col pos convert-read))
(read-fn inp 'read null (object-name inp) mod line col pos
convert-read))
(define (-read-syntax src inp mod line col pos)
(read-fn inp 'read-syntax (list src) src mod line col pos convert-read-syntax))
(read-fn inp 'read-syntax (list src) src mod line col pos
convert-read-syntax))
(values -read -read-syntax -get-info)))

3
collects/syntax/private/id-table.ss
View File

@ -4,6 +4,7 @@
scheme/dict)
(provide id-table-position?)
#|
(require (rename-in scheme/base [car s:car]))
(define-syntax (car stx)
(syntax-case stx ()
@ -13,7 +14,7 @@
'#,(syntax-line stx)
'#,(syntax-column stx))))
(s:car x))]))
|#
(define-struct id-table-position (a b))

31
collects/syntax/private/stxparse/minimatch.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require unstable/struct
(for-syntax scheme/base unstable/struct))
(provide match)
(for-syntax scheme/base scheme/struct-info unstable/struct))
(provide match make)
(define-syntax (match stx)
(syntax-case stx ()
@ -25,7 +25,7 @@
;; (match-p id Pattern SuccessExpr FailureExpr)
(define-syntax (match-p stx)
(syntax-case stx (quote cons list)
(syntax-case stx (quote cons list make struct)
[(match-p x wildcard success failure)
(and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
#'success]
@ -46,6 +46,27 @@
[(match-p x var success failure)
(identifier? #'var)
#'(let ([var x]) success)]
[(match-p x (make S p ...) success failure)
#'(match-p x (struct S (p ...)) success failure)]
[(match-p x (struct S (p ...)) success failure)
(identifier? #'S)
(let ()
(define (not-a-struct)
(raise-syntax-error #f "expected struct name" #'S))
(define si (syntax-local-value #'S not-a-struct))
(unless (struct-info? si)
(not-a-struct))
(let* ([si (extract-struct-info si)]
[predicate (list-ref si 2)]
[accessors (reverse (list-ref si 3))])
(unless (andmap identifier? accessors)
(raise-syntax-error #f "struct has incomplete information" #'S))
(with-syntax ([predicate predicate]
[(accessor ...) accessors])
#'(if (predicate x)
(let ([y (list (accessor x) ...)])
(match-p y (list p ...) success failure))
failure))))]
[(match-p x s success failure)
(prefab-struct-key (syntax-e #'s))
(with-syntax ([key (prefab-struct-key (syntax-e #'s))]
@ -55,3 +76,7 @@
(let ([xps (cdr (vector->list (struct->vector x)))])
(match-p xps (list p ...) success failure))
failure)))]))
(define-syntax struct
(lambda (stx)
(raise-syntax-error #f "illegal use of keyword" stx)))

8
collects/syntax/private/stxparse/rep.ss
View File

@ -693,13 +693,13 @@
(define (check-list-pattern pattern stx)
(match pattern
[#s(pat:datum _base '())
[(make pat:datum _base '())
#t]
[#s(pat:head _base _head tail)
[(make pat:head _base _head tail)
(check-list-pattern tail stx)]
[#s(pat:dots _base _head tail)
[(make pat:dots _base _head tail)
(check-list-pattern tail stx)]
[#s(pat:compound _base '#:pair (list _head tail))
[(make pat:compound _base '#:pair (list _head tail))
(check-list-pattern tail stx)]
[_
(wrong-syntax stx "expected proper list pattern")]))

30
collects/syntax/private/stxparse/runtime-prose.ss
View File

@ -18,7 +18,7 @@
(define (default-failure-handler stx0 f)
(match (simplify-failure f)
[#s(failure x frontier expectation)
[(make failure x frontier expectation)
(report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)]))
(define current-failure-handler
@ -68,14 +68,14 @@
;; simplify* : Failure -> SimpleFailure
(define (simplify* f)
(match f
[#s(join-failures f1 f2)
[(make join-failures f1 f2)
(choose-error (simplify* f1) (simplify* f2))]
[#s(failure x frontier expectation)
[(make failure x frontier expectation)
(match expectation
[#s(expect:thing description '#t chained)
[(make expect:thing description '#t chained)
(let ([chained* (simplify* chained)])
(match chained*
[#s(failure _ chained*-frontier chained*-expectation)
[(make failure _ chained*-frontier chained*-expectation)
(cond [(ineffable? chained*-expectation)
;; If simplified chained failure is ineffable,
;; keep (& adjust) its frontier
@ -93,14 +93,14 @@
;; FIXME: try different selection/simplification algorithms/heuristics
(define (simplify-failure0 f)
(match f
[#s(join-failures f1 f2)
[(make join-failures f1 f2)
(choose-error (simplify-failure0 f1) (simplify-failure0 f2))]
[#s(failure x frontier expectation)
[(make failure x frontier expectation)
(match expectation
[#s(expect:thing description '#t chained)
[(make expect:thing description '#t chained)
(let ([chained* (simplify-failure0 chained)])
(match chained*
[#s(failure _ _ chained*-expectation)
[(make failure _ _ chained*-expectation)
(cond [(ineffable? chained*-expectation)
;; If simplified chained failure is ineffable, ignore it
;; and stick to the one with the description
@ -113,7 +113,7 @@
(define (adjust-failure f base-frontier)
(match f
[#s(failure x frontier expectation)
[(make failure x frontier expectation)
(let ([frontier (dfc-append base-frontier frontier)])
(make-failure x frontier expectation))]))
@ -147,15 +147,15 @@
(define (for-alternative e index stx)
(match e
[#s(expect:thing description transparent? chained)
[(make expect:thing description transparent? chained)
(format "expected ~a" description)]
[#s(expect:atom atom)
[(make expect:atom atom)
(format "expected the literal ~s" atom)]
[#s(expect:literal literal)
[(make expect:literal literal)
(format "expected the literal identifier ~s" (syntax-e literal))]
[#s(expect:message message)
[(make expect:message message)
(format "~a" message)]
[#s(expect:pair)
[(make expect:pair)
(cond [(= index 0)
"expected sequence of terms"]
[else

112
collects/syntax/private/stxparse/runtime.ss
View File

@ -2,6 +2,7 @@
(require scheme/contract/base
scheme/stxparam
scheme/list
unstable/struct
"minimatch.ss"
(for-syntax scheme/base
syntax/stx
@ -159,18 +160,18 @@ A Dynamic Frontier Context (DFC) is one of
(define-struct dfc:pre (parent stx) #:prefab)
(define-struct dfc:post (parent stx) #:prefab)
(define (dfc-empty x) (make-dfc:empty x))
(define (dfc-empty x) (make dfc:empty x))
(define (dfc-add-car parent stx)
(make-dfc:car parent stx))
(make dfc:car parent stx))
(define (dfc-add-cdr parent _)
(match parent
[#s(dfc:cdr uberparent n)
(make-dfc:cdr uberparent (add1 n))]
[_ (make-dfc:cdr parent 1)]))
[(make dfc:cdr uberparent n)
(make dfc:cdr uberparent (add1 n))]
[_ (make dfc:cdr parent 1)]))
(define (dfc-add-pre parent stx)
(make-dfc:pre parent stx))
(make dfc:pre parent stx))
(define (dfc-add-post parent stx)
(make-dfc:post parent stx))
(make dfc:post parent stx))
(define (dfc-add-unbox parent stx)
(dfc-add-car parent stx))
@ -181,16 +182,16 @@ A Dynamic Frontier Context (DFC) is one of
(define (dfc->index dfc)
(match dfc
[#s(dfc:cdr parent n) n]
[(make dfc:cdr parent n) n]
[_ 0]))
(define (dfc->stx dfc)
(match dfc
[#s(dfc:empty stx) stx]
[#s(dfc:car parent stx) stx]
[#s(dfc:cdr parent n) (dfc->stx parent)]
[#s(dfc:pre parent stx) stx]
[#s(dfc:post parent stx) stx]))
[(make dfc:empty stx) stx]
[(make dfc:car parent stx) stx]
[(make dfc:cdr parent n) (dfc->stx parent)]
[(make dfc:pre parent stx) stx]
[(make dfc:post parent stx) stx]))
;; dfc-difference : DFC DFC -> nat
;; Returns N s.t. B = (dfc-add-cdr^N A)
@ -199,10 +200,10 @@ A Dynamic Frontier Context (DFC) is one of
(error 'dfc-difference "~e is not an extension of ~e"
(frontier->sexpr b) (frontier->sexpr a)))
(match (list a b)
[(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
[(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
(unless (equal? pa pb) (whoops))
(- nb na)]
[(list pa #s(dfc:cdr pb nb))
[(list pa (make dfc:cdr pb nb))
(unless (equal? pa pb) (whoops))
nb]
[_
@ -213,16 +214,16 @@ A Dynamic Frontier Context (DFC) is one of
;; puts A at the base, B on top
(define (dfc-append a b)
(match b
[#s(dfc:empty stx) a]
[#s(dfc:car pb stx) (make-dfc:car (dfc-append a pb) stx)]
[#s(dfc:cdr #s(dfc:empty _) nb)
[(make dfc:empty stx) a]
[(make dfc:car pb stx) (make dfc:car (dfc-append a pb) stx)]
[(make dfc:cdr (make dfc:empty _) nb)
;; Special case to merge "consecutive" cdr frames
(match a
[#s(dfc:cdr pa na) (make-dfc:cdr pa (+ na nb))]
[_ (make-dfc:cdr a nb)])]
[#s(dfc:cdr pb nb) (make-dfc:cdr (dfc-append a pb) nb)]
[#s(dfc:pre pb stx) (make-dfc:pre (dfc-append a pb) stx)]
[#s(dfc:post pb stx) (make-dfc:post (dfc-append a pb) stx)]))
[(make dfc:cdr pa na) (make dfc:cdr pa (+ na nb))]
[_ (make dfc:cdr a nb)])]
[(make dfc:cdr pb nb) (make dfc:cdr (dfc-append a pb) nb)]
[(make dfc:pre pb stx) (make dfc:pre (dfc-append a pb) stx)]
[(make dfc:post pb stx) (make dfc:post (dfc-append a pb) stx)]))
;; An Inverted DFC (IDFC) is a DFC inverted for easy comparison.
@ -230,15 +231,15 @@ A Dynamic Frontier Context (DFC) is one of
(define (invert-dfc dfc)
(define (invert dfc acc)
(match dfc
[#s(dfc:empty _) acc]
[#s(dfc:car parent stx)
(invert parent (make-dfc:car acc stx))]
[#s(dfc:cdr parent n)
(invert parent (make-dfc:cdr acc n))]
[#s(dfc:pre parent stx)
(invert parent (make-dfc:pre acc stx))]
[#s(dfc:post parent stx)
(invert parent (make-dfc:post acc stx))]))
[(make dfc:empty _) acc]
[(make dfc:car parent stx)
(invert parent (make dfc:car acc stx))]
[(make dfc:cdr parent n)
(invert parent (make dfc:cdr acc n))]
[(make dfc:pre parent stx)
(invert parent (make dfc:pre acc stx))]
[(make dfc:post parent stx)
(invert parent (make dfc:post acc stx))]))
(invert dfc (dfc-empty 'dummy)))
;; compare-idfcs : IDFC IDFC -> (one-of '< '= '>)
@ -247,28 +248,28 @@ A Dynamic Frontier Context (DFC) is one of
(define (compare-idfcs a b)
(match (list a b)
;; Same constructors
[(list #s(dfc:empty _) #s(dfc:empty _)) '=]
[(list #s(dfc:car pa _) #s(dfc:car pb _))
[(list (make dfc:empty _) (make dfc:empty _)) '=]
[(list (make dfc:car pa _) (make dfc:car pb _))
(compare-idfcs pa pb)]
[(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
[(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
(cond [(< na nb) '<]
[(> na nb) '>]
[(= na nb) (compare-idfcs pa pb)])]
[(list #s(dfc:pre pa _) #s(dfc:pre pb _))
[(list (make dfc:pre pa _) (make dfc:pre pb _))
;; FIXME: possibly just '= here, treat all sides as equiv
(compare-idfcs pa pb)]
[(list #s(dfc:post pa _) #s(dfc:post pb _))
[(list (make dfc:post pa _) (make dfc:post pb _))
;; FIXME: possibly just '= here, treat all sides as equiv
(compare-idfcs pa pb)]
;; Different constructors
[(list #s(dfc:empty _) _) '<]
[(list _ #s(dfc:empty _)) '>]
[(list #s(dfc:pre _ _) _) '<]
[(list _ #s(dfc:pre _ _)) '>]
[(list #s(dfc:car _ _) _) '<]
[(list _ #s(dfc:car _ _)) '>]
[(list #s(dfc:cdr _ _) _) '<]
[(list _ #s(dfc:cdr _ _)) '>]))
[(list (make dfc:empty _) _) '<]
[(list _ (make dfc:empty _)) '>]
[(list (make dfc:pre _ _) _) '<]
[(list _ (make dfc:pre _ _)) '>]
[(list (make dfc:car _ _) _) '<]
[(list _ (make dfc:car _ _)) '>]
[(list (make dfc:cdr _ _) _) '<]
[(list _ (make dfc:cdr _ _)) '>]))
(define (idfc>? a b)
(eq? (compare-idfcs a b) '>))
@ -344,7 +345,7 @@ A Dynamic Frontier Context (DFC) is one of
(lambda (f1)
(let ([combining-fail
(lambda (f2)
(fail (make-join-failures f1 f2)))])
(fail (make join-failures f1 f2)))])
(try* rest-attempts combining-fail)))])
(first-attempt next-fail)))))
@ -380,7 +381,7 @@ An Expectation is one of
(or/c expect? (symbols 'ineffable)))
(define (merge-expectations a b)
(make-expect:disj a b))
(make expect:disj a b))
;; expect->alternatives : Expectation -> (listof Expectation)/#f
;; #f indicates 'ineffable somewhere in expectation
@ -541,7 +542,7 @@ An Expectation is one of
(define fs
(let loop ([f f])
(match f
[#s(join-failures f1 f2)
[(make join-failures f1 f2)
(append (loop f1) (loop f2))]
[_ (list f)])))
(case (length fs)
@ -550,20 +551,21 @@ An Expectation is one of
(define (one-failure->sexpr f)
(match f
[#s(failure x frontier expectation)
[(make failure x frontier expectation)
`(failure ,(frontier->sexpr frontier)
#:term ,(syntax->datum x)
#:expected ,(expectation->sexpr expectation))]))
(define (frontier->sexpr dfc)
(match (invert-dfc dfc)
[#s(dfc:empty _) '()]
[#s(dfc:car p _) (cons 0 (frontier->sexpr p))]
[#s(dfc:cdr p n) (cons n (frontier->sexpr p))]
[#s(dfc:side p _) (cons 'side (frontier->sexpr p))]))
[(make dfc:empty _) '()]
[(make dfc:car p _) (cons 0 (frontier->sexpr p))]
[(make dfc:cdr p n) (cons n (frontier->sexpr p))]
[(make dfc:pre p _) (cons 'pre (frontier->sexpr p))]
[(make dfc:post p _) (cons 'post (frontier->sexpr p))]))
(define (expectation->sexpr expectation)
(match expectation
[#s(expect:thing thing '#t chained)
(make-expect:thing thing #t (failure->sexpr chained))]
[(make expect:thing thing '#t chained)
(make expect:thing thing #t (failure->sexpr chained))]
[_ expectation]))

183
collects/syntax/scribblings/module-reader.scrbl
View File

@ -2,7 +2,8 @@
@(require "common.ss")
@(require (for-label syntax/module-reader
(only-in scribble/reader read-syntax-inside read-inside)))
(only-in scribble/reader
read-syntax-inside read-inside)))
@title[#:tag "module-reader"]{Module Reader}
@ -15,16 +16,17 @@ is the name of the module that will be used in the language position
of read modules; using keywords, the resulting readers can be
customized in a number of ways.
@defform*/subs[[(#%module-begin module-path)
(#%module-begin module-path reader-option ... body ....)
(#%module-begin reader-option ... body ....)]
([reader-option (code:line #:language lang-expr)
(code:line #:read read-expr)
(code:line #:read-syntax read-syntax-expr)
(code:line #:info info-expr)
(code:line #:wrapper1 wrapper1-expr)
(code:line #:wrapper2 wrapper2-expr)
(code:line #:whole-body-readers? whole?-expr)])]{
@defform*/subs[
[(#%module-begin module-path)
(#%module-begin module-path reader-option ... body ....)
(#%module-begin reader-option ... body ....)]
([reader-option (code:line #:language lang-expr)
(code:line #:read read-expr)
(code:line #:read-syntax read-syntax-expr)
(code:line #:info info-expr)
(code:line #:wrapper1 wrapper1-expr)
(code:line #:wrapper2 wrapper2-expr)
(code:line #:whole-body-readers? whole?-expr)])]{
Causes a module written in the @schememodname[syntax/module-reader]
language to define and provide @schemeidfont{read} and
@ -37,26 +39,25 @@ That is, a module @scheme[_something]@scheme[/lang/reader] implemented
as
@schemeblock[
(module reader syntax/module-reader
module-path)
(module reader syntax/module-reader
module-path)
]
creates a reader that converts @scheme[#,(hash-lang)_something]
into
creates a reader that converts @scheme[#,(hash-lang)_something] into
@schemeblock[
(module _name-id module-path
....)
(module _name-id module-path
(#%module-begin ....))
]
where @scheme[_name-id] is derived from the name of the port used by
the reader.
the reader, or @scheme[anonymous-module] if the port has no name.
For example, @scheme[scheme/base/lang/reader] is implemented as
@schemeblock[
(module reader syntax/module-reader
scheme/base)
(module reader syntax/module-reader
scheme/base)
]
The reader functions can be customized in a number of ways, using
@ -68,10 +69,10 @@ reading. For example, you can implement a
using:
@schemeblock[
(module reader syntax/module-reader
honu
#:read read-honu
#:read-syntax read-honu-syntax)
(module reader syntax/module-reader
honu
#:read read-honu
#:read-syntax read-honu-syntax)
]
Similarly, the @scheme[#:info] keyword supplies a procedure to be used
@ -82,17 +83,17 @@ procedure (to be called with the key and default result for default
handling). If @scheme[#:info] is not supplied, the default
info-getting procedure is used.
You can also use the (optional) module @scheme[body] forms to provide more
definitions that might be needed to implement your reader functions.
For example, here is a case-insensitive reader for the
You can also use the (optional) module @scheme[body] forms to provide
more definitions that might be needed to implement your reader
functions. For example, here is a case-insensitive reader for the
@scheme[scheme/base] language:
@schemeblock[
(module reader syntax/module-reader
scheme/base
#:read (wrap read) #:read-syntax (wrap read-syntax)
(define ((wrap reader) . args)
(parameterize ([read-case-sensitive #f]) (apply reader args))))
(module reader syntax/module-reader
scheme/base
#:read (wrap read) #:read-syntax (wrap read-syntax)
(define ((wrap reader) . args)
(parameterize ([read-case-sensitive #f]) (apply reader args))))
]
In many cases, however, the standard @scheme[read] and
@ -105,11 +106,11 @@ alternative definition of the case-insensitive language using
@scheme[#:wrapper1]:
@schemeblock[
(module reader syntax/module-reader
scheme/base
#:wrapper1 (lambda (t)
(parameterize ([read-case-sensitive #f])
(t))))
(module reader syntax/module-reader
scheme/base
#:wrapper1 (lambda (t)
(parameterize ([read-case-sensitive #f])
(t))))
]
Note that using a @tech[#:doc refman]{readtable}, you can implement
@ -125,11 +126,11 @@ that corresponds to a file). Here is the case-insensitive implemented
using this option:
@schemeblock[
(module reader syntax/module-reader
scheme/base
#:wrapper2 (lambda (in r)
(parameterize ([read-case-sensitive #f])
(r in))))
(module reader syntax/module-reader
scheme/base
#:wrapper2 (lambda (in r)
(parameterize ([read-case-sensitive #f])
(r in))))
]
In some cases, the reader functions read the whole file, so there is
@ -148,10 +149,9 @@ the resulting readers:
following reader defines a ``language'' that ignores the contents
of the file, and simply reads files as if they were empty:
@schemeblock[
(module ignored syntax/module-reader
scheme/base
#:wrapper1 (lambda (t) (t) '()))
]
(module ignored syntax/module-reader
scheme/base
#:wrapper1 (lambda (t) (t) '()))]
Note that it is still performing the read, otherwise the module
loader will complain about extra expressions.}
@item{The reader function that is passed to a @scheme[#:wrapper2]
@ -168,22 +168,22 @@ scribble syntax, and the first datum in the file determines the actual
language (which means that the library specification is effectively
ignored):
@schemeblock[
(module reader syntax/module-reader
-ignored-
#:wrapper2
(lambda (in rd stx?)
(let* ([lang (read in)]
[mod (parameterize ([current-readtable
(make-at-readtable)])
(rd in))]
[mod (if stx? mod (datum->syntax #f mod))]
[r (syntax-case mod ()
[(module name lang* . body)
(with-syntax ([lang (datum->syntax
#'lang* lang #'lang*)])
(syntax/loc mod (module name lang . body)))])])
(if stx? r (syntax->datum r))))
(require scribble/reader))
(module reader syntax/module-reader
-ignored-
#:wrapper2
(lambda (in rd stx?)
(let* ([lang (read in)]
[mod (parameterize ([current-readtable
(make-at-readtable)])
(rd in))]
[mod (if stx? mod (datum->syntax #f mod))]
[r (syntax-case mod ()
[(module name lang* . body)
(with-syntax ([lang (datum->syntax
#'lang* lang #'lang*)])
(syntax/loc mod (module name lang . body)))])])
(if stx? r (syntax->datum r))))
(require scribble/reader))
]
This ability to change the language position in the resulting module
@ -191,22 +191,33 @@ expression can be useful in cases such as the above, where the base
language module is chosen based on the input. To make this more
convenient, you can omit the @scheme[module-path] and instead specify
it via a @scheme[#:language] expression. This expression can evaluate
to a datum or syntax object that is used as a language, or it can evaluate to a thunk.
In the latter case, the thunk is invoked to obtain such a datum
before reading the module body begins, in a dynamic extent where
@scheme[current-input-port] is the source input. A syntax object is converted
using @scheme[syntax->datum] when a datum is needed (for @scheme[read] instead of @scheme[read-syntax]).
Using @scheme[#:language], the last
example above can be written more concisely:
to a datum or syntax object that is used as a language, or it can
evaluate to a thunk. In the latter case, the thunk is invoked to
obtain such a datum before reading the module body begins, in a
dynamic extent where @scheme[current-input-port] is the source
input. A syntax object is converted using @scheme[syntax->datum] when
a datum is needed (for @scheme[read] instead of @scheme[read-syntax]).
Using @scheme[#:language], the last example above can be written more
concisely:
@schemeblock[
(module reader syntax/module-reader
#:language read
#:wrapper2 (lambda (in rd stx?)
(parameterize ([current-readtable
(make-at-readtable)])
(rd in)))
(require scribble/reader))
(module reader syntax/module-reader
#:language read
#:wrapper2 (lambda (in rd stx?)
(parameterize ([current-readtable
(make-at-readtable)])
(rd in)))
(require scribble/reader))
]
Note: if such whole-body reader functions return a list with a single
expression that begins with @scheme[#%module-begin], then the
@scheme[syntax/module-reader] language will not inappropriately add
another. This for backwards-compatibility with older code: having a
whole-body reader functions or wrapper functions that return a
@scheme[#%module-begin]-wrapped body is deprectaed.
}
@ -227,7 +238,8 @@ procedures chains to another language that is specified in an input
stream.
@margin-note{The @schememodname[at-exp], @schememodname[reader], and
@schememodname[planet] languages are implemented using this function.}
@schememodname[planet] languages are implemented using this
function.}
The generated functions expect a target language description in the
input stream that is provided to @scheme[read-spec]. The default
@ -239,8 +251,9 @@ reader exception is raised, and @scheme[path-desc-str] is used as a
description of the expected language form in the error message.
@margin-note{The @schememodname[reader] language supplies
@scheme[read] for @scheme[read-spec]. The @schememodname[at-exp] and
@schememodname[planet] languages use the default @scheme[read-spec].}
@scheme[read] for @scheme[read-spec]. The @schememodname[at-exp] and
@schememodname[planet] languages use the default
@scheme[read-spec].}
The result of @scheme[read-spec] is converted to a module path using
@scheme[module-path-parser]. If @scheme[module-path-parser] produces
@ -256,9 +269,9 @@ passed to @scheme[convert-read], @scheme[convert-read-syntax], or
@scheme[convert-get-info], respectively.
@margin-note{The @schememodname[at-exp] language supplies
@scheme[convert-read] and @scheme[convert-read-syntax] to add
@"@"-expression support to the current readtable before chaining to
the given procedures.}
@scheme[convert-read] and @scheme[convert-read-syntax] to add
@"@"-expression support to the current readtable before chaining to
the given procedures.}
The procedures generated by @scheme[make-meta-reader] are not meant
for use with the @schememodname[syntax/module-reader] language; they
@ -277,14 +290,14 @@ are meant to be exported directly.}
@emph{This function is deprecated; the
@schememodname[syntax/module-reader] language can be adapted using the
various keywords to arbitrary readers, and please use it instead.}
various keywords to arbitrary readers; please use it instead.}
Repeatedly calls @scheme[read] on @scheme[in] until an end of file,
collecting the results in order into @scheme[_lst], and derives a
@scheme[_name-id] from @scheme[(object-name in)]. The last five
@scheme[_name-id] from @scheme[(object-name in)]. The last five
arguments are used to construct the syntax object for the language
position of the module. The result is roughly
@schemeblock[
`(module ,_name-id ,mod-path ,@_lst)
`(module ,_name-id ,mod-path ,@_lst)
]}

8
collects/teachpack/2htdp/scribblings/image-gen.ss
View File

@ -28,7 +28,13 @@
(define (handle-image exp)
(printf ".") (flush-output)
(let ([result (parameterize ([current-namespace image-ns]) (eval exp))])
(let ([result
(with-handlers ([exn:fail?
(λ (x)
(printf "\nerror evaluating:\n")
(pretty-print exp)
(raise x))])
(parameterize ([current-namespace image-ns]) (eval exp)))])
(cond
[(image? result)
(let ([fn (exp->filename exp)])

74
collects/teachpack/2htdp/scribblings/image-toc.ss
View File

@ -8,8 +8,8 @@
(list
(list '(image-height (rectangle 100 100 "solid" "black")) 'val 100)
(list '(image-baseline (rectangle 100 100 "solid" "black")) 'val 100)
(list '(image-height (text "Hello" 24 "black")) 'val 24.0)
(list '(image-baseline (text "Hello" 24 "black")) 'val 18.0)
(list '(image-height (text "Hello" 24 "black")) 'val 41.0)
(list '(image-baseline (text "Hello" 24 "black")) 'val 31.0)
(list
'(image-height
(overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
@ -114,6 +114,76 @@
(ellipse 20 10 "solid" "black"))
'image
"28c73238138.png")
(list
'(underlay/xy
(underlay/xy
(ellipse 40 40 "solid" "gray")
10
15
(ellipse 10 10 "solid" "forestgreen"))
20
15
(ellipse 10 10 "solid" "forestgreen"))
'image
"201c231dce2.png")
(list
'(underlay/xy
(rectangle 20 20 "solid" "red")
-20
-20
(rectangle 20 20 "solid" "black"))
'image
"42f9f9e4cf.png")
(list
'(underlay/xy
(rectangle 20 20 "solid" "red")
20
20
(rectangle 20 20 "solid" "black"))
'image
"157ab5efca7.png")
(list
'(underlay/xy
(rectangle 20 20 "outline" "black")
20
0
(rectangle 20 20 "outline" "black"))
'image
"26bd803042c.png")
(list
'(underlay/align
"right"
"top"
(rectangle 50 50 "solid" "seagreen")
(rectangle 40 40 "solid" "silver")
(rectangle 30 30 "solid" "seagreen")
(rectangle 20 20 "solid" "silver"))
'image
"ff2fcb7b87.png")
(list
'(underlay/align
"middle"
"middle"
(rectangle 30 60 "solid" "orange")
(ellipse 60 30 "solid" "purple"))
'image
"2d1e52503d7.png")
(list
'(underlay
(ellipse 10 60 "solid" "red")
(ellipse 20 50 "solid" "black")
(ellipse 30 40 "solid" "red")
(ellipse 40 30 "solid" "black")
(ellipse 50 20 "solid" "red")
(ellipse 60 10 "solid" "black"))
'image
"28253f4c3c.png")
(list
'(underlay
(rectangle 30 60 "solid" "orange")
(ellipse 60 30 "solid" "purple"))
'image
"9858b8d5d.png")
(list
'(overlay/xy
(overlay/xy

64
collects/teachpack/2htdp/scribblings/image.scrbl
View File

@ -318,6 +318,70 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
(ellipse 10 10 "solid" "forestgreen"))]
}
@defproc[(underlay [i1 image?] [i2 image?] [is image?] ...) image?]{
Underlays all of its arguments building a single image.
It behaves like @scheme[overlay], but with the arguments in the reverse order.
That is, the first argument goes
underneath of the second argument, which goes underneath the third argument, etc.
The images are all lined up on their upper-left corners.
@image-examples[(underlay (rectangle 30 60 "solid" "orange")
(ellipse 60 30 "solid" "purple"))
(underlay (ellipse 10 60 "solid" "red")
(ellipse 20 50 "solid" "black")
(ellipse 30 40 "solid" "red")
(ellipse 40 30 "solid" "black")
(ellipse 50 20 "solid" "red")
(ellipse 60 10 "solid" "black"))]
}
@defproc[(underlay/align [x-place x-place?] [y-place y-place?] [i1 image?] [i2 image?] [is image?] ...) image?]{
Underlays all of its image arguments, much like the @scheme[underlay] function, but using
@scheme[x-place] and @scheme[y-place] to determine where the images are lined up. For example, if
@scheme[x-place] and @scheme[y-place] are both @scheme["middle"], then the images are lined up
on their centers.
@image-examples[(underlay/align "middle" "middle"
(rectangle 30 60 "solid" "orange")
(ellipse 60 30 "solid" "purple"))
(underlay/align "right" "top"
(rectangle 50 50 "solid" "seagreen")
(rectangle 40 40 "solid" "silver")
(rectangle 30 30 "solid" "seagreen")
(rectangle 20 20 "solid" "silver"))]
}
@defproc[(underlay/xy [i1 image?] [x real?] [y real?] [i2 image?]) image?]{
Constructs an image by underlaying @scheme[i1] underneath of @scheme[i2] after
shifting @scheme[i2] over by @scheme[x] pixels to the right and @scheme[y]
pixels down.
This is the same as @scheme[(overlay/xy i2 (- x) (- y) i1)].
@image-examples[(underlay/xy (rectangle 20 20 "outline" "black")
20 0
(rectangle 20 20 "outline" "black"))
(underlay/xy (rectangle 20 20 "solid" "red")
20 20
(rectangle 20 20 "solid" "black"))
(underlay/xy (rectangle 20 20 "solid" "red")
-20 -20
(rectangle 20 20 "solid" "black"))
(underlay/xy
(underlay/xy (ellipse 40 40 "solid" "gray")
10
15
(ellipse 10 10 "solid" "forestgreen"))
20
15
(ellipse 10 10 "solid" "forestgreen"))]
}
@defproc[(beside [i1 image?] [i2 image?] [is image?] ...) image?]{
Constructs an image by placing all of the argument images in a
horizontal row, aligned along their top edges.

BIN
collects/teachpack/2htdp/scribblings/img/157ab5efca7.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 179 B

BIN
collects/teachpack/2htdp/scribblings/img/201c231dce2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 965 B

BIN
collects/teachpack/2htdp/scribblings/img/26bd803042c.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 117 B

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