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

Syncing up.

Browse Source 
svn: r12981
This commit is contained in:
Stevie Strickland 2009-01-03 02:51:36 +00:00
commit a80ac8d72f
121 changed files with 8126 additions and 1755 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -0,0 +1,174 @@
#lang scheme
(require htdp/image
htdp/error
(only-in lang/htdp-beginner image?))
(provide (all-defined-out))
(define INSET 5) ;; the space around the image in the canvas
(define RATE 1/30) ;; the clock tick rate
(define TRIES 3) ;; how many times should register try to connect to the server
(define PAUSE 1/2) ;; # secs to wait between attempts to connect to server
(define SQPORT 4567) ;; the port on which universe traffic flows
(define (K w . r) w)
(define (False w) #f)
;
;
;
; ;;; ;;;
; ; ; ; ;
; ; ; ; ;
; ; ;;; ;;;;; ;;;;; ;;; ;;;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;;
; ;;; ;;; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ;;
;
;
;
;; -----------------------------------------------------------------------------
;; Any -> Boolean
(define (scene? i)
(and (image? i) (internal-scene? i)))
;; Image -> Boolean
(define (internal-scene? i)
(and (= 0 (pinhole-x i)) (= 0 (pinhole-y i))))
;; Number -> Integer
(define (number->integer x)
(inexact->exact (floor x)))
;; -----------------------------------------------------------------------------
;; Nat Nat ->String
;; converts i to a string, adding leading zeros, make it at least as long as L
(define (zero-fill i L)
(let ([n (number->string i)])
(string-append (make-string (max (- L (string-length n)) 0) #\0) n)))
;; -----------------------------------------------------------------------------
;; MouseEvent -> [List Nat Nat MouseEventType]
;; turn a mouse event into its pieces
(define (mouse-event->parts e)
(define x (- (send e get-x) INSET))
(define y (- (send e get-y) INSET))
(list x y (cond [(send e button-down?) 'button-down]
[(send e button-up?) 'button-up]
[(send e dragging?) 'drag]
[(send e moving?) 'move]
[(send e entering?) 'enter]
[(send e leaving?) 'leave]
[else ; (send e get-event-type)
(error 'on-mouse-event
(format
"Unknown event type: ~a"
(send e get-event-type)))])))
;; -----------------------------------------------------------------------------
;; Any -> Symbol
(define (name-of draw tag)
(define fname (object-name draw))
(if fname fname tag))
;; -----------------------------------------------------------------------------
;; Any -> Boolean
(define (sexp? x)
(cond
[(empty? x) true]
[(string? x) true]
[(symbol? x) true]
[(number? x) true]
[(char? x) true]
[(pair? x) (and (list? x) (andmap sexp? x))]
[else false]))
(define (no-newline? x)
(not (member #\newline (string->list x))))
;; -----------------------------------------------------------------------------
;; exchange one-line messages between worlds and the server
(define tcp-eof (gensym 'tcp-eof))
;; Any -> Boolean
(define (tcp-eof? a) (eq? tcp-eof a))
;; OutPort Sexp -> Void
(define (tcp-send out msg)
(write msg out)
(newline out)
(flush-output out))
;; InPort -> Sexp
(define (tcp-receive in)
(with-handlers ((exn? (lambda (x) (raise tcp-eof))))
(define x (read in))
(if (eof-object? x)
(raise tcp-eof)
(begin
(read-line in) ;; read the newline
x))))
;
;
;
; ;;; ;;; ; ;
; ; ; ; ; ; ;
; ; ; ; ; ; ;
; ; ; ; ;; ;;;; ; ;;;; ; ;
; ;;;;; ;; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ;;;; ;;; ; ; ; ;
; ;
; ; ;
; ;;;
;; Symbol Any String -> Void
(define (check-pos t c r)
(check-arg
t (and (number? c) (> (number->integer c) 0)) "positive integer" r c))
;; Symbol Any String String *-> Void
(define (check-image tag i rank . other-message)
(if (and (pair? other-message) (string? (car other-message)))
(check-arg tag (image? i) (car other-message) rank i)
(check-arg tag (image? i) "image" rank i)))
;; Symbol Any String -> Void
(define (check-scene tag i rank)
(define error "image with pinhole at (~s,~s)")
(if (image? i)
(check-arg tag (internal-scene? i) "scene" rank (image-pins i))
(check-arg tag #f "scene" rank i)))
;; Symbol Any -> Void
(define (check-scene-result tname i)
(if (image? i)
(check-result tname internal-scene? "scene" i (image-pins i))
(check-result tname (lambda (x) (image? x)) "scene" i)))
(define (image-pins i)
(format "image with pinhole at (~s,~s)" (pinhole-x i) (pinhole-y i)))
;; Symbol Any String -> Void
(define (check-color tag width rank)
(check-arg tag (or (symbol? width) (string? width))
"color symbol or string" rank width))
;; Symbol (union Symbol String) Nat -> Void
(define (check-mode tag s rank)
(check-arg tag (or (eq? s 'solid)
(eq? s 'outline)
(string=? "solid" s)
(string=? "outline" s)) "mode (solid or outline)" rank s))

17
collects/2htdp/private/design.txt Normal file
View File

@ -0,0 +1,17 @@
Files for constructing universe.ss:
world.ss the old world
world% = (clock-mixin ...) -- the basic world
aworld% = (class world% ...) -- the world with recording
universe.ss the universe server
universe% = (clock-mixin ...) -- the basic universe
timer.ss the clock-mixin
check-aux.ss common primitives
image.ss the world image functions
syn-aux.ss syntactic auxiliaries
syn-aux-aux.ss auxiliaries to the syntactic auxiliaries

195
collects/2htdp/private/image.ss Normal file
View File

@ -0,0 +1,195 @@
#lang scheme
(require htdp/image
htdp/error
"check-aux.ss")
;
;
; ;;;;; ;;;;;
; ; ;
; ; ;
; ; ;;; ; ;;;; ;;;; ;;; ; ; ; ; ;; ;;;
; ; ; ;;; ; ; ; ; ; ; ;;;;; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;
; ;;;;; ; ; ; ;; ; ;; ; ;;;; ; ;; ; ; ; ;;;
; ;
; ;;;;
;
(provide (all-from-out htdp/image))
(provide
;; Scene is Image with pinhole in origin
nw:rectangle ;; Number Number Mode Color -> Image
place-image ;; Image Number Number Scene -> Scene
empty-scene ;; Number Number -> Scene
scene+line ;; Scene Number Number Number Number Color -> Scene
;; cut all pieces that are outside the given rectangle
)
(define (nw:rectangle width height mode color)
(check-pos 'rectangle width "first")
(check-pos 'rectangle height "second")
(check-mode 'rectangle mode "third")
(check-color 'rectangle color "fourth")
(put-pinhole (rectangle width height mode color) 0 0))
(define (place-image image x y scene)
(check-image 'place-image image "first")
(check-arg 'place-image (number? x) 'integer "second" x)
(check-arg 'place-image (number? y) 'integer "third" y)
(check-scene 'place-image scene "fourth")
(let ([x (number->integer x)]
[y (number->integer y)])
(place-image0 image x y scene)))
(define (empty-scene width height)
(check-pos 'empty-scene width "first")
(check-pos 'empty-scene height "second")
(put-pinhole
(overlay (rectangle width height 'solid 'white)
(rectangle width height 'outline 'black))
0 0))
(define (scene+line img x0 y0 x1 y1 c)
;; img and c are checked via calls to add-line from image.ss
(check-arg 'scene+line (scene? img) "scene" "first" "plain image")
(check-arg 'scene+line (number? x0) "number" "second" x0)
(check-arg 'scene+line (number? y0) "number" "third" y0)
(check-arg 'scene+line (number? x1) "number" "fourth" x1)
(check-arg 'scene+line (number? y1) "number" "fifth" y1)
(let ([x0 (number->integer x0)]
[x1 (number->integer x1)]
[y0 (number->integer y0)]
[y1 (number->integer y1)])
(add-line-to-scene0 img x0 y0 x1 y1 c)))
;; Image Number Number Image -> Image
(define (place-image0 image x y scene)
(define sw (image-width scene))
(define sh (image-height scene))
(define ns (overlay/xy scene x y image))
(define nw (image-width ns))
(define nh (image-height ns))
(if (and (= sw nw) (= sh nh)) ns (shrink ns 0 0 (- sw 1) (- sh 1))))
;; Image Number Number Number Number Color -> Image
(define (add-line-to-scene0 img x0 y0 x1 y1 c)
(define w (image-width img))
(define h (image-height img))
(cond
[(and (<= 0 x0) (< x0 w) (<= 0 x1) (< x1 w) (<= 0 y0) (< y0 w) (<= 0 y1) (< y1 w))
(add-line img x0 y0 x1 y1 c)]
[(= x0 x1) ;; vertical
(if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)]
[(= y0 y1) ;; horizontal
(if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)]
[else
(local ((define lin (points->line x0 y0 x1 y1))
(define dir (direction x0 y0 x1 y1))
(define-values (upp low lft rgt) (intersections lin w h))
(define (add x y) (add-line img x0 y0 x y c)))
(cond
[(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior
(case dir
[(upper-left) (if (number? upp) (add upp 0) (add 0 lft))]
[(lower-left) (if (number? low) (add low h) (add 0 lft))]
[(upper-right) (if (number? upp) (add upp 0) (add h rgt))]
[(lower-right) (if (number? low) (add low h) (add w rgt))]
[else (error 'dir "contract violation: ~e" dir)])]
[(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry!
(add-line-to-scene0 img x1 y1 x0 y0 c)]
[else
(cond
[(and (number? upp) (number? low)) (add-line img upp 0 low h c)]
[(and (number? upp) (number? lft)) (add-line img upp 0 0 lft c)]
[(and (number? upp) (number? rgt)) (add-line img upp 0 w rgt c)]
[(and (number? low) (number? lft)) (add-line img low h 0 lft c)]
[(and (number? low) (number? rgt)) (add-line img low h w rgt c)]
[(and (number? lft) (number? rgt)) (add-line img 0 lft w rgt c)]
[else img])]))]))
;; Nat Nat -> Nat
;; y if in [0,h], otherwise the closest boundary
(define (app y h)
(cond
[(and (<= 0 y) (< y h)) y]
[(< y 0) 0]
[else (- h 1)]))
;; Nat Nat Nat Nat -> (union 'upper-left 'upper-right 'lower-left 'lower-right)
;; how to get to (x1,y1) from (x0,y0)
(define (direction x0 y0 x1 y1)
(string->symbol
(string-append
(if (<= y0 y1) "lower" "upper") "-" (if (<= x0 x1) "right" "left"))))
#| TESTS
'direction
(equal? (direction 10 10 0 0) 'upper-left)
(equal? (direction 10 10 20 20) 'lower-right)
(equal? (direction 10 10 0 20) 'lower-left)
(equal? (direction 10 10 20 0) 'upper-right)
|#
;; -----------------------------------------------------------------------------
;; LINEs
;; Number Number -> LINE
;; create a line from a slope and the intersection with the y-axis
(define-struct lyne (slope y0))
;; Nat Nat Nat Nat -> LINE
;; determine the line function from the four points (or the attributes)
;; ASSUME: (not (= x0 x1))
(define (points->line x0 y0 x1 y1)
(local ((define slope (/ (- y1 y0) (- x1 x0))))
(make-lyne slope (- y0 (* slope x0)))))
;; LINE Number -> Number
(define (of ln x) (+ (* (lyne-slope ln) x) (lyne-y0 ln)))
;; LINE Nat Nat -> [Opt Number] [Opt Number] [Opt Number] [Opt Number]
;; where does the line intersect the rectangle [0,w] x [0,h]
;; (values UP LW LF RT) means the line intersects with
;; the rectangle [0,w] x [0,h] at (UP,0) or (LW,h) or (0,LF) or (w,RT)
;; when a field is false, the line doesn't interesect with that side
(define (intersections l w h)
(values
(opt (X l 0) w) (opt (X l h) w) (opt (lyne-y0 l) h) (opt (of l w) h)))
;; Number Number -> [Opt Number]
(define (opt z lft) (if (<= 0 z lft) z false))
;; LINE Number -> Number
;; the x0 where LINE crosses y(x) = h
;; assume: LINE is not a horizontal
(define (X ln h) (/ (- h (lyne-y0 ln)) (lyne-slope ln)))
;; --- TESTS ---
#|
(define line1 (points->line 0 0 100 100))
(= (of line1 0) 0)
(= (of line1 100) 100)
(= (of line1 50) 50)
(= (X (make-lyne 1 0) 0) 0)
(= (X (make-lyne 1 0) 100) 100)
(equal? (call-with-values
(lambda () (intersections (points->line -10 -10 110 110) 100 100))
list)
(list 0 100 0 100))
(equal? (call-with-values
(lambda () (intersections (points->line 0 10 100 80) 100 100))
list)
(list false false 10 80))
|#
;; -----------------------------------------------------------------------------
;
;

30
collects/2htdp/private/last.ss Normal file
View File

@ -0,0 +1,30 @@
#lang scheme/gui
(require "timer.ss")
(provide last-mixin)
(define last-mixin
(mixin (start-stop<%>) ()
(field [end:ch (make-channel)])
;; X -> Void
(define/override (stop! w)
(send-to-last w)
(super stop! w))
;; -> World
(define/public (last)
(define result (yield end:ch))
(if (exn? result) (raise result) result))
(field [dr:cust (current-custodian)])
;; X -> Void
;; send x to last method
(define/private (send-to-last x)
(parameterize ((current-custodian dr:cust))
(thread (lambda () (channel-put end:ch x)))))
(super-new)))

60
collects/2htdp/private/syn-aux-aux.ss Normal file
View File

@ -0,0 +1,60 @@
#lang scheme
(require htdp/error)
;
;
;
; ;;; ;;;
; ; ; ; ;
; ; ; ;
; ; ; ; ;;;; ; ; ; ; ; ;
; ;;; ; ; ; ; ;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;; ; ;
; ;;; ;;;; ; ; ; ; ;; ; ; ;
; ;
; ; ;
; ;;;
(provide nat> nat? proc> bool> num> ip> string> symbol>)
;; Any -> Boolean
(define (nat? x)
(and (number? x) (integer? x) (>= x 0)))
;; Symbol X -> X
(define (bool> tag x)
(check-arg tag (boolean? x) "boolean" "first" x)
x)
;; Symbol X -> X
(define (string> tag x)
(check-arg tag (string? x) "string" "first" x)
x)
(define ip> string>)
;; Symbol X -> X
(define (symbol> tag x)
(check-arg tag (symbol? x) "symbol" "second" x)
x)
;; Symbol X Nat -> X
(define (proc> tag f ar)
(check-proc tag f ar "first"
(if (> ar 1)
(format "~a arguments" ar)
"one argument"))
f)
;; Symbol X (Number -> Boolean) String String -> X
(define (num> tag x pred? spec which)
(check-arg tag (and (number? x) (pred? x)) spec which x)
x)
;; Symbol X String -> X
(define (nat> tag x spec)
(check-arg tag (nat? x) spec "natural number" x)
x)

43
collects/2htdp/private/syn-aux.ss Normal file
View File

@ -0,0 +1,43 @@
#lang scheme
(provide define-keywords function-with-arity except err check-flat-spec
(all-from-out "syn-aux-aux.ss"))
(require "syn-aux-aux.ss"
(for-template "syn-aux-aux.ss"
scheme
(rename-in lang/prim (first-order->higher-order f2h))))
(define-syntax-rule (define-keywords the-list (kw coerce) ...)
(begin
(provide kw ...)
(define-syntax (kw x)
(raise-syntax-error 'kw "used out of context" x))
...
(define-for-syntax the-list (list (list 'kw (coerce ''kw)) ...))))
(define-syntax function-with-arity
(syntax-rules (except)
[(_ arity)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(x) #`(proc> #,tag (f2h x) arity)]
[_ (err tag p)])))]
[(_ arity except extra)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(x) #`(proc> #,tag (f2h x) arity)]
extra
[_ (err tag p)])))]))
(define (err spec p)
(raise-syntax-error #f "illegal specification" #`(#,spec . #,p) p))
;; Symbol (Symbol X -> X) -> (X -> X)
(define (check-flat-spec tag coerce>)
(lambda (p)
(syntax-case p ()
[(b) #'(coerce> tag b)]
[_ (err tag p)])))

38
collects/2htdp/private/timer.ss Normal file
View File

@ -0,0 +1,38 @@
#lang scheme/gui
;; The module provides a timer mixing for world and universe.
;; The interface ensures that super class provides start and stop method,
;; plus a call back for clock ticks. The super-init call provides the
;; on-tick parameter, which the super-class uses to define the callback.
(require "check-aux.ss")
(provide clock-mixin start-stop<%>)
(define start-stop<%> (interface () start! ptock stop!))
;; T = (U (World -> World) (list (World -> World) Nat))
;; X [(list (World -> World) Nat) -> X] [(World -> World) -> X] -> [T -> X]
(define (selector default lchoice pchoice)
(lambda (on-tick)
(cond
[(cons? on-tick) (lchoice on-tick)]
[(procedure? on-tick) (pchoice on-tick)]
[else default])))
(define clock-mixin
(mixin (start-stop<%>) ()
(inherit ptock)
(init-field [on-tick #f])
(field [rate ((selector 0 second (lambda _ RATE)) on-tick)]
[timer (new timer% [notify-callback (lambda () (ptock))])])
(define/override (start!)
(unless (<= rate 0)
(send timer start (number->integer (* 1000 rate))))
(super start!))
(define/override (stop! w)
(send timer stop)
(super stop! w))
(super-new [tick ((selector void first (lambda (x) x)) on-tick)])))

363
collects/2htdp/private/universe.ss Normal file
View File

@ -0,0 +1,363 @@
#lang scheme/gui
(require (for-syntax "syn-aux.ss")
"check-aux.ss"
"timer.ss"
"last.ss"
scheme/match
htdp/error
(only-in mzlib/etc evcase)
string-constants)
(provide universe%)
;
;
;
; ; ; ;
; ; ; ;
; ; ;
; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;;
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ;;; ; ;;; ;;;
;
;
;
(define universe%
(last-mixin
(clock-mixin
(class* object% (start-stop<%>) (inspect #f) (super-new)
(init-field ;; type Result = (make-bundle Universe [Listof Mail])
universe0 ;; the initial state of the universe
on-new ;; Universe World -> Result
on-msg ;; Universe World Message -> Result
tick ;; Universe -> Result
(on-disconnect ;; Universe World -> Result
(lambda (u w) (list u)))
(to-string #f) ;; Universe -> String
)
(field [universe universe0])
;; -----------------------------------------------------------------------
;; dealing with events
(define-syntax-rule
;; A B ... -> Void
(def/cback pub (pname a ...)
;; Universe A B ... -> (cons Universe Mail)
;; effect: change server state, broadcast mails
name)
(begin
(pub pname)
(define (pname a ...)
(define (handler e) (stop! e))
(with-handlers ([exn? handler])
(define r (check-state-x-mail 'name (name universe a ...)))
(define u (bundle-state r))
(set! universe u)
(unless (boolean? to-string) (send gui add (to-string u)))
(broadcast (bundle-mails r))))))
(def/cback private (pmsg world received) on-msg)
(def/cback private (pdisconnect world) on-disconnect)
(def/cback private (pnew world) ppnew)
(define/private (ppnew uni p)
(world-send p 'okay)
(on-new uni p))
(def/cback public (ptock) tick)
;; Symbol Any -> Result
;; check that r is Result
;; effect: stop the server if the callbacks perform badly
(define/private (check-state-x-mail tag r)
(with-handlers ((exn? (lambda (x) (stop! x))))
(define s (format "expected from ~a, given: " tag))
(unless (bundle? r)
(error tag (format "(make-bundle Universe [Listof Mail]) ~a~e" s r)))
r))
;; -----------------------------------------------------------------------
;; start and stop server, start and stop the universe
(field [worlds '()] ;; [Listof World]
[gui (new gui%
[stop-server (lambda () (stop! universe))]
[stop-and-restart (lambda () (restart))])]
[dr:custodian (current-custodian)]
[the-custodian (make-custodian)])
;; start the universe, enable registrations and message exchanges
(define/public (start!)
(set! the-custodian (make-custodian))
(parameterize ([current-custodian the-custodian])
(define (loop)
(apply sync
(handle-evt (tcp-accept-evt tcp-listener) add-world)
(map world-wait-for-msg worlds)))
(define (add-world in-out)
(with-handlers ((tcp-eof? (lambda _ (loop))))
(define in (first in-out))
(define next (tcp-receive in))
(match next
[(cons 'REGISTER info)
(let* ([w (create-world in (second in-out) info)])
(set! worlds (cons w worlds))
(pnew w)
(send gui add (format "~a signed up" info))
(loop))]
[else (loop)])))
(define (world-wait-for-msg p)
(handle-evt (world-in p)
(lambda (in)
(with-handlers
((tcp-eof?
(lambda (e)
(handler p e
(lambda ()
(if (null? worlds)
(restart)
(loop)))))))
(define r (tcp-receive in))
(send gui add (format "~a ->: ~a" (world-name p) r))
(pmsg p r)
(loop)))))
(define tcp-listener
(with-handlers ((exn:fail:network? (lambda (x) (stop! x))))
(tcp-listen SQPORT 4 #t)))
;; --- go universe go ---
(set! worlds '())
(set! universe universe0)
(send gui add "a new universe is up and running")
(thread loop)))
;; World Exn (-> X) -> X
(define/private (handler p e cont)
(close-output-port (world-out p))
(close-input-port (world-in p))
(send gui add (format "~a !! closed port" (world-name p)))
(set! worlds (remq p worlds))
(pdisconnect p)
(cont))
;; [Listof Mail] -> Void
;; send payload of messages to designated worlds
(define/private (broadcast lm)
;;; --- why the heck is there no exception handler -------------
(for-each (lambda (p+m)
;; what exception should I catch
;; remove the world from the list
;; factor out from elsewhere
;; can this mean I perform a callback during a callback?
;; collect 'bad' worlds instead and disconnect them later?
;; (handler
(with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n"))))
(define w (mail-to p+m))
(define n (world-name w))
(define p (mail-content p+m))
(unless (memq w worlds)
(send gui add (format "~s not on list" n)))
(when (memq w worlds)
(world-send w p)
(send gui add (format "-> ~a: ~a" n p)))))
lm))
(define/private (restart)
;; I am running in a custodian that is about to be killed,
;; so let's switch to one up in the hierarchy
(let ([old-t (current-thread)]
[go (make-semaphore)])
(parameterize ([current-custodian dr:custodian])
(thread (lambda ()
(sync old-t go)
(start!))))
(send gui add "stopping the universe")
(send gui add "----------------------------------")
(for-each (lambda (w)
(close-input-port (world-in w))
(close-output-port (world-out w)))
worlds)
(custodian-shutdown-all the-custodian)
(semaphore-post go)))
(define/public (stop! msg)
(send gui show #f)
(custodian-shutdown-all the-custodian))
;; -----------------------------------------------------------------------
;; initialize the universe and run
(send gui show #t)
(start!)))))
;
;
;
; ; ; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ; ;;; ; ;; ; ;;;; ;;;
; ; ; ; ; ;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;;
; ;; ;; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ;;; ; ;; ;;;; ;;;
;
;
;
(provide
world? ;; Any -> Boolean
world=? ;; World World -> Boolean
world1 ;; sample worlds
world2
world3)
;; --- the server representation of a world ---
(define-struct world (in out name info) #:transparent)
;; World = (make-world IPort OPort Symbol [Listof Sexp])
(define world1 (make-world (current-input-port) (current-output-port) 'sk '()))
(define world2 (make-world (current-input-port) (current-output-port) 'mf '()))
(define world3 (make-world (current-input-port) (current-output-port) 'rf '()))
(define (world=? u v)
(check-arg 'world=? (world? u) 'world "first" u)
(check-arg 'world=? (world? v) 'world "second" v)
(eq? u v))
;; IPort OPort Sexp -> Player
(define (create-world i o info)
(if (and (pair? info) (symbol? (car info)))
(make-world i o (car info) (cdr info))
(make-world i o (gensym 'world) info)))
;; Player S-exp -> Void
(define (world-send p sexp)
(tcp-send (world-out p) sexp))
;
;
;
; ;;; ; ; ;
; ; ; ; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ;; ; ; ;
; ; ; ; ; ;
; ; ; ; ; ;
; ; ; ; ; ;
; ;;; ;;; ;
;
;
;
;; effect: create and show a gui with two buttons and an editor for logging
(define gui%
(class frame%
(init stop-server stop-and-restart)
(inherit show)
(define/augment (on-close) (end))
(super-new [label "Universe"][width 500][height 300][style '(metal)])
(field
[end (lambda _ (show #f) (stop-server))]
[panel (new horizontal-panel% [parent this] [stretchable-height #f]
[alignment '(center center)])]
[stop (new button% [parent panel] [label "stop"] [callback end])]
[s&re (new button% [parent panel] [label "stop and restart"]
[callback (lambda (but evt) (stop-and-restart))])]
[text (new text%)]
[edit (new editor-canvas% [parent this] [editor text]
[style '(no-border combo no-hscroll auto-vscroll)])])
;; add lines to the end of the text
(define/public (add str)
(queue-callback
(lambda ()
(send text lock #f)
(send text insert (format "~a\n" str) (send text last-position))
(send text lock #t))))
;; -------------------------------------------------------------------------
;; add menu, lock, and show
(copy-and-paste this)
(send text lock #t)))
;; -----------------------------------------------------------------------------
;; Frame Text -> Void
;; add menu bar to frame for copying all of the text
(require string-constants)
(define (copy-and-paste frame)
(define mb (new menu-bar% [parent frame]))
(define edit (new menu%
[label (string-constant edit-menu-label)]
[parent mb]))
(new menu-item%
[label (string-constant copy-menu-item)]
[parent edit]
[shortcut #\c]
[callback (lambda (m e)
(define t (send frame get-focus-object))
(when (is-a? t editor<%>)
(send t copy)))])
(new menu-item%
[label (string-constant select-all-menu-item)]
[parent edit]
[shortcut #\a]
[callback (lambda (m e)
(define t (send frame get-focus-object))
(when (is-a? t text%)
(send t set-position 0 (send t last-position))))])
(void))
;
;
; ;;; ;;; ; ;;
; ;; ;; ;
; ;; ;; ;;; ;;; ;
; ; ; ; ; ; ; ;
; ; ; ; ;;;; ; ;
; ; ; ; ; ; ;
; ; ; ; ; ; ;
; ;;; ;;; ;;;;; ;;;;; ;;;;;
;
;
;
;
(provide
;; type Bundle = (make-bundle Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
)
(define-struct bundle (state mails) #:transparent)
(set! make-bundle
(let ([make-bundle make-bundle])
(lambda (state mails)
(check-arg 'make-bundle (list? mails) "list [of mails]" "second" mails)
(for-each (lambda (c)
(check-arg 'make-bundle (mail? c) "mail" "(elements of) second" c))
mails)
(make-bundle state mails))))
(define-struct mail (to content) #:transparent)
(set! make-mail
(let ([make-mail make-mail])
(lambda (to content)
(check-arg 'make-mail (world? to) 'world "first" to)
(check-arg 'make-mail (sexp? content) 'S-expression "second" content)
(make-mail to content))))

382
collects/2htdp/private/world.ss Normal file
View File

@ -0,0 +1,382 @@
#lang scheme/gui
(require "check-aux.ss"
"timer.ss"
"last.ss"
htdp/image
htdp/error
mzlib/runtime-path
mrlib/bitmap-label
string-constants
mrlib/gif)
(provide world% aworld%)
;
;
;
; ; ; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ; ;;; ; ;; ; ;;;;
; ; ; ; ; ;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ;; ;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;
; ; ; ;;; ; ;; ;;;;
;
;
;
;; -----------------------------------------------------------------------------
;; packages for broadcasting information to the universe
(define-struct package (world message) #:transparent)
;; World Sexp -> Package
(define (create-package w m)
(check-arg 'make-package (sexp? m) 'sexp "second" m)
(make-package w m))
(provide
(rename-out (create-package make-package)) ;; World S-expression -> Package
package? ;; Any -> Package
)
(define world%
(last-mixin
(clock-mixin
(class* object% (start-stop<%>)
(inspect #f)
(init-field
world0 ;; World
(tick K)) ;; (U (World -> World) (list (World -> World) Nat))
(init
(on-key K) ;; World KeyEvent -> World
(on-mouse K) ;; World Nat Nat MouseEvent -> World
(on-receive #f) ;; (U #f (World S-expression -> World))
(on-draw #f) ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
(stop-when False) ;; World -> Boolean
(record? #f) ;; Boolean
(register #f)) ;; (U #f String (list String Symbol))
;; -----------------------------------------------------------------------
(field (world world0))
;; (U World Package) -> Boolean
;; does the new world differ from the old?
;; effect: if so, set world
(define/private (set-world new-world)
(when (package? new-world)
(broadcast (package-message new-world))
(set! new-world (package-world new-world)))
(if (equal? world new-world)
#t
(begin
(set! world new-world)
#f)))
;; -----------------------------------------------------------------------
(field [*out* #f] ;; (U #f OutputPort), where to send messages to
[*rec* (make-custodian)] ;; Custodian, monitor traffic
[host (cond
[(string? register) register]
[(pair? register) (car register)]
[else register])]
[name (cond
[(string? register) (gensym 'world)]
[(pair? register) (second register)]
[else register])])
(define/private (register-with-host)
(define FMTtry "unable to register with ~a after ~s tries")
(define FMTcom "unable to register with ~a due to protocol problems")
;; try to register with the server n times
(define (register n)
(printf "trying to register with ~a ...\n" host)
(with-handlers ((tcp-eof?
(lambda (x)
(error 'register FMTcom host)))
(exn:fail:network?
(lambda (x)
(if (= n 1)
(error 'register FMTtry host TRIES)
(begin (sleep PAUSE)
(register (- n 1)))))))
(define-values (in out) (tcp-connect host SQPORT))
(tcp-send out `(REGISTER ,(if name name (gensym 'world))))
(if (eq? (tcp-receive in) 'okay)
(values in out)
(raise tcp-eof))))
;; --- now register, obtain connection, and spawn a thread for receiving
(parameterize ([current-custodian *rec*])
(define-values (in out) (register TRIES))
(define dis (text "the universe disappeared" 11 'red))
(define (RECEIVE)
(sync
(handle-evt
in
(lambda (in)
(with-handlers ((tcp-eof? (compose (handler #f)
(lambda (e)
(set! draw (lambda (w) dis))
(pdraw)
e))))
;; --- "the universe disconnected" should come from here ---
(define msg (tcp-receive in))
(cond
[(sexp? msg) (prec msg) (RECEIVE)] ;; break loop if EOF
[#t (error 'RECEIVE "sexp expected, received: ~e" msg)]))))))
(printf "... successful registered and ready to receive\n")
(set! *out* out)
(thread RECEIVE)))
(define/private (broadcast msg)
(when *out*
(check-result 'send sexp? "Sexp expected; given ~e\n" msg)
(tcp-send *out* msg)))
;; -----------------------------------------------------------------------
(field
(draw (cond
[(procedure? on-draw) on-draw]
[(pair? on-draw) (first on-draw)]
[else on-draw]))
(live (not (boolean? draw)))
(width (if (pair? on-draw) (second on-draw) #f))
(height (if (pair? on-draw) (third on-draw) #f)))
;; the visible world
(field [enable-images-button void] ;; used if stop-when call produces #t
[disable-images-button void]
[visible (new pasteboard%)])
(define (show-canvas)
(send visible set-cursor (make-object cursor% 'arrow))
(let ([fst-scene (ppdraw)])
(set! width (if width width (image-width fst-scene)))
(set! height (if height height (image-height fst-scene)))
(create-frame)
(show fst-scene)))
;; effect: create, show and set the-frame
(define/pubment (create-frame)
(define play-back:cust (make-custodian))
(define frame (new (class frame%
(super-new)
(define/augment (on-close)
(callback-stop! 'frame-stop)
(custodian-shutdown-all play-back:cust)))
(label (if name (format "~a's World" name) "World"))
(stretchable-width #f)
(stretchable-height #f)
(style '(no-resize-border metal))))
(define editor-canvas
(new (class editor-canvas%
(super-new)
;; deal with keyboard events
(define/override (on-char e)
(when live (pkey (send e get-key-code))))
;; deal with mouse events if live and within range
(define/override (on-event e)
(define l (mouse-event->parts e))
(when live
(when (and (<= 0 (first l) width) (<= 0 (second l) height))
(pmouse . l)))))
(parent frame)
(editor visible)
(style '(no-hscroll no-vscroll))
(horizontal-inset INSET)
(vertical-inset INSET)))
(send editor-canvas min-client-width (+ width INSET INSET))
(send editor-canvas min-client-height (+ height INSET INSET))
(set!-values (enable-images-button disable-images-button)
(inner (values void void) create-frame frame play-back:cust))
(send editor-canvas focus)
(send frame show #t))
;; Image -> Void
;; show the image in the visible world
(define/public (show pict)
(send visible begin-edit-sequence)
(send visible lock #f)
(let ([s (send visible find-first-snip)]
[c (send visible get-canvas)])
(when s (send visible delete s))
(send visible insert (send pict copy) 0 0))
(send visible lock #t)
(send visible end-edit-sequence))
;; -----------------------------------------------------------------------
;; callbacks
(field
(key on-key)
(mouse on-mouse)
(rec on-receive))
(define-syntax-rule (def/pub-cback (name arg ...) transform)
;; Any ... -> Boolean
(define/public (name arg ...)
(queue-callback
(lambda ()
(with-handlers ([exn:break? (handler #f)][exn? (handler #t)])
(define changed-world? (set-world (transform world arg ...)))
(unless changed-world?
(when draw (pdraw))
(when (pstop)
(callback-stop! 'name)
(enable-images-button)))
changed-world?)))))
;; tick, tock : deal with a tick event for this world
(def/pub-cback (ptock) tick)
;; key events
(def/pub-cback (pkey ke) key)
;; mouse events
(def/pub-cback (pmouse x y me) mouse)
;; receive revents
(def/pub-cback (prec msg) rec)
;; -----------------------------------------------------------------------
;; draw : render this world
(define/private (pdraw) (show (ppdraw)))
(define/private (ppdraw)
(check-scene-result (name-of draw 'your-draw) (draw world)))
;; -----------------------------------------------------------------------
;; stop-when
(field [stop stop-when])
(define/private (pstop)
(define result (stop world))
(check-result (name-of stop 'your-stop-when) boolean? "boolean" result)
result)
;; -----------------------------------------------------------------------
;; start & stop
(define/public (callback-stop! msg)
(stop! world))
(define (handler re-raise)
(lambda (e)
(disable-images-button)
(stop! (if re-raise e world))))
(define/public (start!)
(when draw (show-canvas))
(when host (register-with-host)))
(define/public (stop! w)
(set! live #f)
(custodian-shutdown-all *rec*))
;; -------------------------------------------------------------------------
;; initialize the world and run
(super-new)
(start!)))))
;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png"))
(define break-button:label
((bitmap-label-maker (string-constant break-button-label) break-btn:path) '_))
(define-runtime-path image-button:path '(lib "icons/file.gif"))
(define image-button:label ((bitmap-label-maker "Images" image-button:path) '_))
(define aworld%
(class world% (super-new)
(inherit-field world0 tick key mouse rec draw rate width height)
(inherit show callback-stop!)
;; Frame Custodian -> (-> Void)
;; adds the stop animation and image creation button,
;; whose callbacks runs as a thread in the custodian
;; provide a function for switching button enabling
(define/augment (create-frame frm play-back-custodian)
(define p (new horizontal-pane% [parent frm][alignment '(center center)]))
(define (switch)
(send stop-button enable #f)
(send image-button enable #t))
(define (stop) (send stop-button enable #f))
(define-syntax-rule (btn l a y ...)
(new button% [parent p] [label l] [style '(border)]
[callback (lambda a y ...)]))
(define stop-button
(btn break-button:label (b e) (callback-stop! 'stop-images) (switch)))
(define image-button
(btn image-button:label (b e)
(parameterize ([current-custodian play-back-custodian])
(thread (lambda () (play-back)))
(stop))))
(send image-button enable #f)
(values switch stop))
(field [event-history '()]) ;; [Listof Evt]
;; Symbol Any *-> Void
(define/private (add-event type . stuff)
(set! event-history (cons (cons type stuff) event-history)))
;; --- new callbacks ---
(define-syntax-rule (def/over-cb (pname name arg ...))
(define/override (pname arg ...)
(when (super pname arg ...) (add-event name arg ...))))
(def/over-cb (ptock tick))
(def/over-cb (pkey key e))
(def/over-cb (pmouse mouse x y me))
(def/over-cb (prec rec m))
;; --> Void
;; re-play the history of events; create a png per step; create animated gif
;; effect: write to user-chosen directory
(define/private (play-back)
;; World EventRecord -> World
(define (world-transition world fst) (apply (car fst) world (cdr fst)))
;; --- creating images
(define total (+ (length event-history) 1))
(define digt# (string-length (number->string total)))
(define imag# 0)
(define bmps '())
;; Image -> Void
(define (save-image img)
(define bm (make-object bitmap% width height))
(define dc (make-object bitmap-dc% bm))
(send dc clear)
(send img draw dc 0 0 0 0 width height 0 0 #f)
(set! imag# (+ imag# 1))
(send bm save-file (format "i~a.png" (zero-fill imag# digt#)) 'png)
(set! bmps (cons bm bmps)))
;; --- choose place
(define img:dir (get-directory "image directory:" #f (current-directory)))
(when img:dir
(parameterize ([current-directory img:dir])
(define last
(foldr (lambda (event world)
(save-image (draw world))
(show (text (format "~a/~a created" imag# total) 18 'red))
(world-transition world event))
world0
event-history))
(show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
(create-animated-gif rate (reverse bmps))
(show (draw last)))))))
;; Number [Listof (-> bitmap)] -> Void
;; turn the list of thunks into animated gifs
;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
;; [Listof (-> bitmap)] -> Void
;; turn the list of thunks into animated gifs
;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
(define (create-animated-gif R bitmap-list)
(when (file-exists? ANIMATED-GIF-FILE) (delete-file ANIMATED-GIF-FILE))
(write-animated-gif bitmap-list (if (> +inf.0 R 0) (number->integer R) 5)
ANIMATED-GIF-FILE
#:one-at-a-time? #t
#:loop? #f))
(define ANIMATED-GIF-FILE "i-animated.gif")

311
collects/2htdp/universe.ss Executable file
View File

@ -0,0 +1,311 @@
#lang scheme/gui
#| TODO:
-- make window resizable :: why?
|#
(require (for-syntax "private/syn-aux.ss")
"private/syn-aux-aux.ss"
"private/syn-aux.ss"
"private/check-aux.ss"
"private/image.ss"
"private/world.ss"
"private/universe.ss"
htdp/error
(rename-in lang/prim (first-order->higher-order f2h))
(only-in mzlib/etc evcase))
(provide (all-from-out "private/image.ss"))
(provide
sexp? ;; Any -> Boolean
scene? ;; Any -> Boolean
)
;; Spec = (on-tick Expr)
;; | (on-tick Expr Expr)
;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
(define-keywords AllSpec
[on-tick (function-with-arity
1
except
[(x rate)
#'(list (proc> 'on-tick (f2h x) 1)
(num> 'on-tick rate positive? "pos. number" "rate"))])])
;
;
;
; ; ; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ; ;;; ; ;; ; ;;;;
; ; ; ; ; ;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ;; ;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;
; ; ; ;;; ; ;; ;;;;
;
;
;
(provide big-bang ;; <syntax> : see below
make-package ;; World Sexp -> Package
package? ;; Any -> Boolean
run-movie ;; [Listof Image] -> true
;; A MouseEventType is one of:
;; - 'button-down
;; - 'button-up
;; - 'drag
;; - 'move
;; - 'enter
;; - 'leave
mouse-event? ;; Any -> Boolean
mouse=? ;; MouseEventType MouseEventType -> Boolean
;; KeyEvent is one of:
;; -- Char
;; -- Symbol
key-event? ;; Any -> Boolean
key=? ;; KeyEvent KeyEvent -> Boolean
;; IP : a string that points to a machine on the net
LOCALHOST ;; IP
)
(provide-higher-order-primitive
run-simulation (create-scene) ; (Number Number Number (Nat -> Scene) -> true)
)
;; Expr = (big-bang Expr WorldSpec ...)
;; WorldSpec = AllSpec
;; | (on-draw Expr)
;; | (on-draw Expr Expr Expr)
;; -- on-draw must specify a rendering function; it may specify canvas dimensions
;; | (on-key Expr)
;; -- on-key must specify a key event handler
;; | (on-mouse Expr)
;; -- on-mouse must specify a mouse event handler
;; | (stop-when Expr)
;; -- stop-when must specify a boolean-valued function
;; | (register Expr)
;; | (register Expr Expr)
;; -- register must specify the internet address of a host (including LOCALHOST)
;; -- it may specify a world's name
;; | (record? Expr)
;; -- should the session be recorded and turned into PNGs and an animated GIF
;; | (on-receive Expr)
;; -- on-receive must specify a receive handler
(define-keywords WldSpec
[on-draw (function-with-arity
1
except
[(f width height)
#'(list (proc> 'on-draw (f2h f) 1)
(nat> 'on-draw width "width")
(nat> 'on-draw height "height"))])]
[on-mouse (function-with-arity 4)]
[on-key (function-with-arity 2)]
[on-receive (function-with-arity 2)]
[stop-when (function-with-arity 1)]
[register (lambda (tag)
(lambda (p)
(syntax-case p ()
[(host) #`(ip> #,tag host)]
[(ip name) #`(list (ip> #,tag ip) (symbol> #,tag name))]
[_ (err tag p)])))]
[record? (lambda (tag)
(lambda (p)
(syntax-case p ()
[(b) #`(bool> #,tag b)]
[_ (err tag p)])))])
(define-syntax (big-bang stx)
(syntax-case stx ()
[(big-bang) (raise-syntax-error #f "bad world description" stx)]
[(big-bang w s ...)
(let* ([Spec (append AllSpec WldSpec)]
[kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
[rec? #'#f]
[spec (map (lambda (stx)
(syntax-case stx ()
[(kw . E)
(and (identifier? #'kw)
(for/or ([n kwds]) (free-identifier=? #'kw n)))
(begin
(when (free-identifier=? #'kw #'record?)
(syntax-case #'E ()
[(V) (set! rec? #'V)]
[_ (err 'record? stx)]))
(cons (syntax-e #'kw) (syntax E)))]
[_ (raise-syntax-error
'big-bang "not a legal big-bang clause" stx)]))
(syntax->list (syntax (s ...))))]
;; assert: all bind = (kw . E) and kw is constrained via Bind
[args (map (lambda (x)
(define kw (car x))
(define co (assq kw Spec))
(list kw ((cadr co) (cdr x))))
spec)])
#`(send (new (if #,rec? aworld% world%) [world0 w] #,@args) last))]))
;
;
;
; ; ; ; ; ;;;
; ; ; ; ; ; ;
; ; ; ; ; ; ;
; ; ; ;;; ; ;; ; ;;;; ; ; ; ; ; ;
; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ;; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
; ; ; ;;; ; ;; ;;;; ; ; ;; ; ; ;
;
;
;
(define (run-simulation f)
(check-proc 'run-simulation f 1 "first" "one argument")
(big-bang 1 (on-tick add1) (on-draw f)))
(define (run-movie r m*)
(check-arg 'run-movie (positive? r) "positive number" "first" r)
(check-arg 'run-movie (list? m*) "list (of images)" "second" m*)
(for-each (lambda (m) (check-image 'run-movie m "first" "list of images")) m*)
(let* ([fst (car m*)]
[wdt (image-width fst)]
[hgt (image-height fst)])
(big-bang
m*
(on-tick rest r)
(on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m))))
(stop-when empty?))))
(define (mouse-event? a)
(pair? (member a '(button-down button-up drag move enter leave))))
(define (mouse=? k m)
(check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
(check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
(eq? k m))
(define (key-event? k)
(or (char? k) (symbol? k)))
(define (key=? k m)
(check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
(check-arg 'key=? (key-event? m) 'KeyEvent "second" m)
(eqv? k m))
(define LOCALHOST "127.0.0.1")
;; -----------------------------------------------------------------------------
;
;
;
; ; ; ;
; ; ; ;
; ; ;
; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;;
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ;;; ; ;;; ;;;
;
;
;
(provide
;; type World
world? ;; Any -> Boolean
world=? ;; World World -> Boolean
world1 ;; sample worlds
world2
world3
;; type Bundle = (make-bundle Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
universe ;; <syntax> : see below
universe2 ;; (World World -> U) (U World Message) -> U
)
;; Expr = (universe Expr UniSpec)
;; UniSpec = AllSepc
;; | (on-new Expr)
;; -- on-new must specify a 'new world" handler; what happens when a world joins
;; | (on-msg Expr)
;; -- on-msg must specify a 'message' handler
;; | (on-disconnect Expr)
;; -- on-disconnect may specify a handler for the event that a world is leaving
;; | (to-string Expr)
;; -- to-string specifies how to render the universe as a string for display
;; in the console
(define-keywords UniSpec
[on-new (function-with-arity 2)]
[on-msg (function-with-arity 3)]
[on-disconnect (function-with-arity 2)]
[to-string (function-with-arity 1)])
(define-syntax (universe stx)
(syntax-case stx ()
[(universe) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u bind ...)
(let* ([Spec (append AllSpec UniSpec)]
[kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
[spec (map (lambda (stx)
(syntax-case stx ()
[(kw . E)
(and (identifier? #'kw)
(for/or ([n kwds]) (free-identifier=? #'kw n)))
(cons (syntax-e #'kw) (syntax E))]
[(kw E)
(and (identifier? #'kw)
(for/or ([n kwds]) (free-identifier=? #'kw n)))
(list (syntax-e #'kw) (syntax E))]
[_ (raise-syntax-error
'universe "not a legal universe clause" stx)]))
(syntax->list (syntax (bind ...))))]
;; assert: all bind = (kw . E) and kw is constrained via Bind
[args (map (lambda (x)
(define kw (car x))
(define co (assq kw Spec))
(list kw ((cadr co) (cdr x))))
spec)]
[domain (map car args)])
(cond
[(not (memq 'on-new domain))
(raise-syntax-error #f "missing on-new clause" stx)]
[(not (memq 'on-msg domain))
(raise-syntax-error #f "missing on-msg clause" stx)]
[else ; (and (memq #'on-new domain) (memq #'on-msg domain))
#`(send (new universe% [universe0 u] #,@args) last)]))]))
;; (World World -> U) (U World Msg) -> U
(define (universe2 create process)
;; UniState = '() | (list World) | Universe
;; UniState World -> (cons UniState [Listof (list World S-expression)])
(define (nu s p)
(cond
[(null? s) (make-bundle (list p) '())]
[(not (pair? s)) (make-bundle s '())]
[(null? (rest s)) (create (first s) p)]
[else (error 'create "a third world is signing up!")]))
(universe '()
(on-new nu)
(on-msg process)
#;
(on-tick (lambda (u) (printf "hello!\n") (list u)) 1)))

10
collects/compiler/decompile.ss
View File

@ -23,7 +23,7 @@
(close-output-port out)
in)))])
(let ([n (match v
[(struct compilation-top (_ prefix (struct primitive (n)))) n]
[(struct compilation-top (_ prefix (struct primval (n)))) n]
[else #f])])
(hash-set! table n (car b)))))
table))
@ -77,7 +77,7 @@
lift-ids)
(map (lambda (stx id)
`(define ,id ,(if stx
`(#%decode-syntax ,stx #;(stx-encoded stx))
`(#%decode-syntax ,(stx-encoded stx))
#f)))
stxs stx-ids)))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
@ -126,7 +126,7 @@
`(let ()
,@defns
,(decompile-expr rhs globs '(#%globals) closed))))]
[(struct sequence (forms))
[(struct seq (forms))
`(begin ,@(map (lambda (form)
(decompile-form form globs stack closed))
forms))]
@ -179,7 +179,7 @@
`(#%checked ,id)))]
[(struct topsyntax (depth pos midpt))
(list-ref/protect globs (+ midpt pos) 'topsyntax)]
[(struct primitive (id))
[(struct primval (id))
(hash-ref primitive-table id)]
[(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack closed)
@ -249,7 +249,7 @@
[(struct apply-values (proc args-expr))
`(#%apply-values ,(decompile-expr proc globs stack closed)
,(decompile-expr args-expr globs stack closed))]
[(struct sequence (exprs))
[(struct seq (exprs))
`(begin ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack closed)))]
[(struct beg0 (exprs))

83
collects/compiler/zo-parse.ss
View File

@ -7,11 +7,18 @@
;; ----------------------------------------
;; Structures to represent bytecode
(define-syntax-rule (define-form-struct id (field-id ...))
(define-syntax-rule (define-form-struct* id id+par (field-id ...))
(begin
(define-struct id (field-id ...) #:transparent)
(define-struct id+par (field-id ...) #:transparent)
(provide (struct-out id))))
(define-syntax define-form-struct
(syntax-rules ()
[(_ (id sup) . rest)
(define-form-struct* id (id sup) . rest)]
[(_ id . rest)
(define-form-struct* id id . rest)]))
(define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this
(define-form-struct prefix (num-lifts toplevels stxs)) ; sets up top-level and syntax-object array
@ -21,43 +28,46 @@
(define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id
;; In stxs of prefix:
(define-form-struct stx (encoded)) ; todo: decode syntax objects
(define-form-struct stx (encoded))
(define-form-struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
(define-form-struct form ())
(define-form-struct (expr form) ())
(define-form-struct lam (name flags num-params rest? closure-map max-let-depth body)) ; `lambda'
(define-form-struct closure (code gen-id)) ; a static closure (nothing to close over)
(define-form-struct case-lam (name clauses)) ; each clause is an lam
(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body max-let-depth))
(define-form-struct let-one (rhs body)) ; pushes one value onto stack
(define-form-struct let-void (count boxes? body)) ; create new stack slots
(define-form-struct install-value (count pos boxes? rhs body)) ; set existing stack slot(s)
(define-form-struct let-rec (procs body)) ; put `letrec'-bound closures into existing stack slots
(define-form-struct boxenv (pos body)) ; box existing stack element
(define-form-struct (lam expr) (name flags num-params rest? closure-map max-let-depth body)) ; `lambda'
(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over)
(define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam
(define-form-struct localref (unbox? offset clear?)) ; access local via stack
(define-form-struct (let-one expr) (rhs body)) ; pushes one value onto stack
(define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots
(define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s)
(define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots
(define-form-struct (boxenv expr) (pos body)) ; box existing stack element
(define-form-struct toplevel (depth pos const? ready?)) ; access binding via prefix array (which is on stack)
(define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
(define-form-struct (localref expr) (unbox? pos clear?)) ; access local via stack
(define-form-struct application (rator rands)) ; function call
(define-form-struct branch (test then else)) ; `if'
(define-form-struct with-cont-mark (key val body)) ; `with-continuation-mark'
(define-form-struct beg0 (seq)) ; `begin0'
(define-form-struct sequence (forms)) ; `begin'
(define-form-struct splice (forms)) ; top-level `begin'
(define-form-struct varref (toplevel)) ; `#%variable-reference'
(define-form-struct assign (id rhs undef-ok?)) ; top-level or module-level set!
(define-form-struct apply-values (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc)
(define-form-struct primitive (id)) ; direct preference to a kernel primitive
(define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack)
(define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
(define-form-struct (application expr) (rator rands)) ; function call
(define-form-struct (branch expr) (test then else)) ; `if'
(define-form-struct (with-cont-mark expr) (key val body)) ; `with-continuation-mark'
(define-form-struct (beg0 expr) (seq)) ; `begin0'
(define-form-struct (seq form) (forms)) ; `begin'
(define-form-struct (splice form) (forms)) ; top-level `begin'
(define-form-struct (varref expr) (toplevel)) ; `#%variable-reference'
(define-form-struct (assign expr) (id rhs undef-ok?)) ; top-level or module-level set!
(define-form-struct (apply-values expr) (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc)
(define-form-struct (primval expr) (id)) ; direct preference to a kernel primitive
;; Definitions (top level or within module):
(define-form-struct def-values (ids rhs))
(define-form-struct def-syntaxes (ids rhs prefix max-let-depth))
(define-form-struct def-for-syntax (ids rhs prefix max-let-depth))
(define-form-struct (def-values form) (ids rhs))
(define-form-struct (def-syntaxes form) (ids rhs prefix max-let-depth))
(define-form-struct (def-for-syntax form) (ids rhs prefix max-let-depth))
;; Top-level `require'
(define-form-struct req (reqs dummy))
(define-form-struct (req form) (reqs dummy))
;; A static closure can refer directly to itself, creating a cycle
(define-struct indirect ([v #:mutable]) #:prefab)
@ -145,7 +155,7 @@
(make-with-cont-mark key val body)]))
(define (read-sequence v)
(make-sequence v))
(make-seq v))
(define (read-define-values v)
(make-def-values
@ -173,7 +183,7 @@
(define (read-begin0 v)
(match v
[(struct sequence (exprs))
[(struct seq (exprs))
(make-beg0 exprs)]))
(define (read-boxenv v)
@ -429,9 +439,12 @@
;; Synatx unmarshaling
(define-form-struct wrapped (datum wraps certs))
(define-form-struct lexical-rename (alist))
(define-form-struct phase-shift (amt src dest))
(define-form-struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?))
(define-form-struct wrap ())
(define-form-struct (lexical-rename wrap) (alist))
(define-form-struct (phase-shift wrap) (amt src dest))
(define-form-struct (module-rename wrap) (phase kind set-id unmarshals renames mark-renames plus-kern?))
(define-form-struct all-from-module (path phase src-phase exceptions prefix))
(define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id))
@ -696,7 +709,7 @@
[read-accept-quasiquote #t])
(read (open-input-bytes s))))]
[(reference)
(make-primitive (read-compact-number cp))]
(make-primval (read-compact-number cp))]
[(small-list small-proper-list)
(let* ([l (- ch cpt-start)]
[ppr (eq? cpt-tag 'small-proper-list)])

5
collects/drscheme/private/bitmap-message.ss
View File

@ -5,7 +5,7 @@
(define bitmap-message%
(class canvas%
(inherit min-width min-height get-dc)
(inherit min-width min-height get-dc refresh)
(define bm #f)
(define/override (on-paint)
(when bm
@ -14,6 +14,7 @@
(define/public (set-bm b)
(set! bm b)
(min-width (send bm get-width))
(min-height (send bm get-height)))
(min-height (send bm get-height))
(refresh))
(super-new (stretchable-width #f)
(stretchable-height #f))))

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

@ -3103,8 +3103,9 @@ module browser threading seems wrong.
[demand-callback
(λ (mi)
(let ([target (get-edit-target-object)])
(send mi enable (get-edit-target-object))
(send mi check (and target (send target get-overwrite-mode)))))]
(send mi enable (is-a? target text%))
(when (is-a? target text%)
(send mi check (and target (send target get-overwrite-mode))))))]
[callback (λ (x y)
(let ([target (get-edit-target-object)])
(send target set-overwrite-mode

34
collects/framework/private/frame.ss
View File

@ -1942,6 +1942,13 @@
(send text-to-search set-position anchor-pos))))))
(send tlw hide-search)))))
(send search/replace-keymap map-function "f3" "unhide-search-and-toggle-focus")
(send search/replace-keymap add-function "unhide-search-and-toggle-focus"
(λ (text evt)
(let ([tlw (send text get-top-level-window)])
(when tlw
(send tlw unhide-search-and-toggle-focus)))))
(define searchable-canvas%
(class editor-canvas%
(inherit refresh get-dc get-client-size)
@ -1981,19 +1988,7 @@
(define/public (get-case-sensitive-search?) case-sensitive-search?)
(define replace-visible? (preferences:get 'framework:replace-visible?))
(define/override (edit-menu:find-callback menu evt)
(cond
[hidden?
(unhide-search #t)]
[(or (not text-to-search)
(send (send text-to-search get-canvas) has-focus?))
(send find-edit set-position 0 (send find-edit last-position))
(send find-canvas focus)]
[else
(let ([canvas (send text-to-search get-canvas)])
(when canvas
(send canvas focus)))])
#t)
(define/override (edit-menu:find-callback menu evt) (unhide-search-and-toggle-focus) #t)
(define/override (edit-menu:create-find?) #t)
(define/override (edit-menu:find-next-callback menu evt) (search 'forward) #t)
@ -2100,6 +2095,19 @@
(send find-edit set-position 0 (send find-edit last-position))
(send (send find-edit get-canvas) focus))))
(define/public (unhide-search-and-toggle-focus)
(cond
[hidden?
(unhide-search #t)]
[(or (not text-to-search)
(send (send text-to-search get-canvas) has-focus?))
(send find-edit set-position 0 (send find-edit last-position))
(send find-canvas focus)]
[else
(let ([canvas (send text-to-search get-canvas)])
(when canvas
(send canvas focus)))]))
(define/public (search searching-direction)
(unhide-search #f)
(send find-edit search searching-direction #t))

5
collects/framework/private/keymap.ss
View File

@ -1311,12 +1311,13 @@
(send-frame (λ (f) (send f replace&search 'forward))))
(add "replace & search backward"
(send-frame (λ (f) (send f replace&search 'backward))))
(add "unhide search and toggle focus"
(send-frame (λ (f) (send f unhide-search-and-toggle-focus))))
(add "hide-search"
(send-frame (λ (f) (send f hide-search))))
(map "c:g" "hide-search")
(map "f3" "search forward")
(map "f3" "unhide search and toggle focus")
(map "c:s" "search forward")
(map "c:r" "search backward")
(case (system-type)

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

File diff suppressed because it is too large Load Diff

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

@ -11,6 +11,12 @@ that space, and the cat responds by taking a step. If the cat is
completely boxed in and thus unable reach the border, you win. If the
cat does reach the border, you lose.
To get some insight into the cat's behavior, hold down the ``h''
key. It will show you the cells that are on the cat's shortest path to
the edge, assuming that the cell underneath the mouse has been
blocked, so you can experiment to see how the shortest paths change
by moving your mouse around.
The game was inspired by this one the one at
@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game
Design} and has essentially the same rules. It also inspired the final

5
collects/guibuilder/tool.ss
View File

@ -12,6 +12,8 @@
(provide tool@)
(define-syntax (name stx) (syntax-case stx () [(_ x e) #'(let ((x e)) x)]))
(define tool@
(unit
(import drscheme:tool^)
@ -20,6 +22,7 @@
(define (phase2)
(drscheme:get/extend:extend-unit-frame
(lambda (drs:frame%)
(name guibuilder-frame%
(class drs:frame%
(inherit get-insert-menu get-edit-target-object)
@ -69,6 +72,6 @@
(send gb create-main-panel)
(send gb set-caret-owner #f 'display))))))
(inherit register-capability-menu-item)
(register-capability-menu-item 'drscheme:special:insert-gui-tool (get-insert-menu))))))
(register-capability-menu-item 'drscheme:special:insert-gui-tool (get-insert-menu)))))))
(drscheme:language:register-capability 'drscheme:special:insert-gui-tool (flat-contract boolean?) #t))))

26
collects/handin-server/scribblings/checker.scrbl
View File

@ -353,20 +353,24 @@ code.}
Similar to @scheme[!procedure] and @scheme[!procedure*] for
integers.}
@deftogether[(
@defform*[((!test expr)
(!test/exn expr)
(!test expr result)
(!test expr result equal?))]{
(!test expr result equal?))]
@defform[(!test/exn expr)]
)]{
The first form checks that the given expression evaluates to a
non-@scheme[#f] value in the submission context, throwing an error
otherwise. The second form checks that the given expression throws
an @scheme[exn:fail?] error, throwing an error otherwise.
The third form compares the result of evaluation,
requiring it to be equal to @scheme[result]. The fourth allows
specifying an equality procedure. Note that the @scheme[result] and
@scheme[equal?] forms are @italic{not} evaluated in the submission
context.}
The first @scheme[!test] form checks that the given expression
evaluates to a non-@scheme[#f] value in the submission context,
throwing an error otherwise. The second form compares the result of
evaluation, requiring it to be equal to @scheme[result]. The third
allows specifying an equality procedure. The @scheme[!test/exn] form
checks that the given expression throws an @scheme[exn:fail?] error,
throwing an error otherwise.
For the latter two @scheme[!test] forms, note that the
@scheme[result] and @scheme[equal?] forms are @italic{not} evaluated
in the submission context.}
@defform[(!eval expr)]{

10
collects/htdp/world.ss
View File

@ -903,9 +903,11 @@ Matthew
(queue-callback
(lambda ()
(with-handlers ([exn:break? break-handler][exn? exn-handler])
(set! the-world (f the-world e))
(add-event KEY e)
(redraw-callback))))))
(let ([new-world (f the-world e)])
(unless (equal? new-world the-world)
(set! the-world new-world)
(add-event KEY e)
(redraw-callback))))))))
;; f : [World Nat Nat MouseEventType -> World]
;; esp : EventSpace
@ -920,7 +922,7 @@ Matthew
(when (and (<= 0 x WIDTH) (<= 0 y HEIGHT))
(with-handlers ([exn:break? break-handler][exn? exn-handler])
(let ([new-world (f the-world x y m)])
(unless (eq? new-world the-world)
(unless (equal? new-world the-world)
(set! the-world new-world)
(add-event MOUSE x y m)
(redraw-callback)))))))))

25
collects/lang/htdp-langs.ss
View File

@ -662,11 +662,16 @@
data-class-names)))))))))
(define (get-teachpack-from-user parent)
(define tp-dir (collection-path "teachpack" "htdp"))
(define tp-dirs (list (collection-path "teachpack" "htdp")
(collection-path "teachpack" "2htdp")))
(define columns 2)
(define tps (filter
(λ (x) (file-exists? (build-path tp-dir x)))
(directory-list tp-dir)))
(define tps (apply
append
(map (λ (tp-dir)
(filter
(λ (x) (file-exists? (build-path tp-dir x)))
(directory-list tp-dir)))
tp-dirs)))
(define sort-order (λ (x y) (string<=? (path->string x) (path->string y))))
(define pre-installed-tps (sort tps sort-order))
(define dlg (new dialog% [parent parent] [label (string-constant drscheme)]))
@ -837,9 +842,15 @@
(cond
[(send pre-installed-lb get-selection)
=>
(λ (i) `(lib ,(send pre-installed-lb get-string i)
"teachpack"
"htdp"))]
(λ (i)
(define f (send pre-installed-lb get-string i))
(cond
[(file-exists? (build-path (collection-path "teachpack" "htdp") f))
`(lib ,f "teachpack" "htdp")]
[(file-exists? (build-path (collection-path "teachpack" "2htdp") f))
`(lib ,f "teachpack" "2htdp")]
[else (error 'figuer-out-answer "argh: ~a ~a"
(collection-path "teachpack" "htdp") f)]))]
[(send user-installed-lb get-selection)
=>
(λ (i) `(lib ,(send user-installed-lb get-string i)

128
collects/lang/private/imageeq.ss
View File

@ -12,132 +12,8 @@
(or (is-a? a image-snip%)
(is-a? a cache-image-snip%)))
(define size-dc (delay (make-object bitmap-dc% (make-object bitmap% 1 1))))
(define (snip-size a)
(cond
[(is-a? a cache-image-snip%)
(send a get-size)]
[else
(let* ([dc (force size-dc)]
[wb (box 0)]
[hb (box 0)])
(send a get-extent dc 0 0 wb hb #f #f #f #f)
(values (unbox wb)
(unbox hb)))]))
(define (image=? a-raw b-raw)
(unless (image? a-raw) (raise-type-error 'image=? "image" 0 a-raw b-raw))
(unless (image? b-raw) (raise-type-error 'image=? "image" 1 a-raw b-raw))
(let ([a (coerce-to-cache-image-snip a-raw)]
[b (coerce-to-cache-image-snip b-raw)])
(let-values ([(aw ah) (snip-size a)]
[(bw bh) (snip-size b)]
[(apx apy) (send a get-pinhole)]
[(bpx bpy) (send b get-pinhole)])
(and (= aw bw)
(= ah bh)
(= apx bpx)
(= apy bpy)
(same/alpha? (argb-vector (send a get-argb))
(argb-vector (send b get-argb)))))))
(define (same/alpha? v1 v2)
(let loop ([i (vector-length v1)])
(or (zero? i)
(let ([a1 (vector-ref v1 (- i 4))]
[a2 (vector-ref v2 (- i 4))])
(and (or (= a1 a2 255)
(and (= a1 a2)
(= (vector-ref v1 (- i 3)) (vector-ref v2 (- i 3)))
(= (vector-ref v1 (- i 2)) (vector-ref v2 (- i 2)))
(= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1)))))
(loop (- i 4)))))))
(define image-snip-cache (make-hash-table 'weak))
;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
(define (coerce-to-cache-image-snip snp)
(cond
[(hash-table-get image-snip-cache snp (λ () #f)) => values]
[(is-a? snp image-snip%)
(let* ([bmp (send snp get-bitmap)]
[cis
(if bmp
(let ([bmp-mask (or (send bmp get-loaded-mask)
(send snp get-bitmap-mask)
(bitmap->mask bmp))])
(bitmaps->cache-image-snip (copy-bitmap bmp)
(copy-bitmap bmp-mask)
(floor (/ (send bmp get-width) 2))
(floor (/ (send bmp get-height) 2))))
(let-values ([(w h) (snip-size snp)])
(let* ([bmp (make-object bitmap%
(inexact->exact (floor w))
(inexact->exact (floor h)))]
[bdc (make-object bitmap-dc% bmp)])
(send snp draw bdc 0 0 0 0 w h 0 0 'no-caret)
(send bdc set-bitmap #f)
(bitmaps->cache-image-snip bmp
(bitmap->mask bmp)
(floor (/ w 2))
(floor (/ h 2))))))])
(hash-table-put! image-snip-cache snp cis)
cis)]
[else snp]))
;; copy-bitmap : bitmap -> bitmap
;; does not copy the mask.
(define (copy-bitmap bitmap)
(let* ([w (send bitmap get-width)]
[h (send bitmap get-height)]
[copy (make-object bitmap% w h)]
[a-dc (make-object bitmap-dc% copy)])
(send a-dc clear)
(send a-dc draw-bitmap bitmap 0 0)
(send a-dc set-bitmap #f)
copy))
;; bitmap->mask : bitmap -> bitmap
(define (bitmap->mask bitmap)
(let* ([w (send bitmap get-width)]
[h (send bitmap get-height)]
[s (make-bytes (* 4 w h))]
[new-bitmap (make-object bitmap% w h)]
[dc (make-object bitmap-dc% new-bitmap)])
(send dc clear)
(send dc draw-bitmap bitmap 0 0)
(send dc get-argb-pixels 0 0 w h s)
(let loop ([i (* 4 w h)])
(unless (zero? i)
(let ([r (- i 3)]
[g (- i 2)]
[b (- i 1)])
(unless (and (eq? 255 (bytes-ref s r))
(eq? 255 (bytes-ref s g))
(eq? 255 (bytes-ref s b)))
(bytes-set! s r 0)
(bytes-set! s g 0)
(bytes-set! s b 0))
(loop (- i 4)))))
(send dc set-argb-pixels 0 0 w h s)
(begin0
(send dc get-bitmap)
(send dc set-bitmap #f))))
(define (bitmaps->cache-image-snip color mask px py)
(let ([w (send color get-width)]
[h (send color get-height)])
(new cache-image-snip%
[width w]
[height h]
[dc-proc
(lambda (dc dx dy)
(send dc draw-bitmap color dx dy 'solid
(send the-color-database find-color "black")
mask))]
[argb-proc
(lambda (argb-vector dx dy)
(overlay-bitmap argb-vector dx dy color mask))]
[px px]
[py py]))))
;; Rely on image-snip% implementing equal<%>:
(equal? a-raw b-raw)))

8
collects/lang/private/intermediate-funs.ss
View File

@ -1,7 +1,7 @@
(module intermediate-funs scheme/base
(require "teachprims.ss"
mzlib/etc
mzlib/list
scheme/list
syntax/docprovide
(for-syntax scheme/base))
@ -33,6 +33,12 @@
(ormap ((X -> boolean) (listof X) -> boolean)
"(ormap p (list x-1 ... x-n)) = (or (p x-1) (or ... (p x-n)))")
(argmin ((X -> real) (listof X) -> X)
"to find the (first) element of the list that minimizes the output of the function")
(argmax ((X -> real) (listof X) -> X)
"to find the (first) element of the list that minimizes the output of the function")
(memf ((X -> boolean) (listof X) -> (union false (listof X)))
"to determine whether the first argument produces true for some value in the second argument")
(apply ((X-1 ... X-N -> Y) X-1 ... X-i (list X-i+1 ... X-N) -> Y)

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

@ -10,8 +10,7 @@ namespace.
|#
(module teachprims mzscheme
(require "../imageeq.ss"
mzlib/list
(require mzlib/list
mzlib/etc)
(define-syntax (define-teach stx)
@ -202,68 +201,25 @@ namespace.
(hash-table-put! ht a prev)
(loop v))))
prev)))))]
[union-equal? (lambda (a b)
(let ([a (union-find a)]
[b (union-find b)])
(if (eq? a b)
#t
(begin
(hash-table-put! ht b a)
#f))))])
[union-equal!? (lambda (a b)
(let ([a (union-find a)]
[b (union-find b)])
(if (eq? a b)
#t
(begin
(hash-table-put! ht b a)
#f))))])
(let ? ([a a][b b])
(or (eqv? a b)
(cond
[(box? a)
(and (box? b)
(? (unbox a) (unbox b)))]
[(pair? a)
(and (pair? b)
(or (union-equal? a b)
(and (? (car a) (car b))
(? (cdr a) (cdr b)))))]
[(vector? a)
(and (vector? b)
(= (vector-length a) (vector-length b))
(or (union-equal? a b)
(andmap ?
(vector->list a)
(vector->list b))))]
[(image? a)
(and (image? b)
(image=? a b))]
[(real? a)
(and epsilon
(real? b)
(beginner-=~ a b epsilon))]
[(struct? a)
(and (struct? b)
(let-values ([(ta sa?) (struct-info a)]
[(tb sb?) (struct-info b)])
(and (not sa?)
(not sb?)
(eq? ta tb)
(or (union-equal? a b)
(? (struct->vector a)
(struct->vector b))))))]
[(hash-table? a)
(and (hash-table? b)
(eq? (immutable? a) (immutable? b))
(eq? (hash-table? a 'weak) (hash-table? b 'weak))
(eq? (hash-table? a 'equal) (hash-table? b 'equal))
(let ([al (hash-table-map a cons)]
[bl (hash-table-map b cons)])
(and (= (length al) (length bl))
(or (union-equal? a b)
(andmap
(lambda (ai)
(? (hash-table-get b (car ai) (lambda () (not (cdr ai))))
(cdr ai)))
al)))))]
[else (equal? a b)])))))
(cond
[(real? a)
(and (real? b)
(beginner-=~ a b epsilon))]
[(union-equal!? a b) #t]
[else (equal?/recur a b ?)]))))
(define-teach beginner equal?
(lambda (a b)
(tequal? a b #f)))
(equal? a b)))
(define-teach beginner =~
(lambda (a b c)

172
collects/mred/private/kernel.ss
View File

@ -47,7 +47,7 @@
(let ([defined null])
(lambda (stx)
(syntax-case stx ()
[(_ name print-name super args id ...)
[(_ name print-name super (intf ...) args id ...)
(let ([nm (syntax-e (syntax name))]
[sn (syntax-e (syntax super))]
[ids (map syntax-e (syntax->list (syntax (id ...))))])
@ -78,11 +78,11 @@
(syntax
(define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
(make-primitive-class
(lambda (class prop:object preparer dispatcher)
(lambda (class prop:object preparer dispatcher more-props)
(kernel:primitive-class-prepare-struct-type!
c prop:object class preparer dispatcher))
c prop:object class preparer dispatcher more-props))
kernel:initialize-primitive-object
'print-name super 'args
'print-name super (list intf ...) 'args
'(old ...)
'(new ...)
(list
@ -110,8 +110,8 @@
(define-a-class name intf super args id ...)
(define intf (class->interface name))
(provide (protect intf))))])))
(define-class object% #f #f)
(define-class window% object% #f
(define-class object% #f () #f)
(define-class window% object% () #f
on-drop-file
pre-on-event
pre-on-char
@ -147,11 +147,11 @@
set-focus
gets-focus?
centre)
(define-class item% window% #f
(define-class item% window% () #f
set-label
get-label
command)
(define-class message% item% #f
(define-class message% item% () #f
get-font
set-label
on-drop-file
@ -160,7 +160,7 @@
on-size
on-set-focus
on-kill-focus)
(define-private-class editor% editor<%> object% #f
(define-private-class editor% editor<%> object% () #f
dc-location-to-editor-location
editor-location-to-dc-location
set-inactive-caret-threshold
@ -300,7 +300,7 @@
(define-function write-editor-version)
(define-function set-editor-print-margin)
(define-function get-editor-print-margin)
(define-class bitmap% object% #f
(define-class bitmap% object% () #f
get-argb-pixels
get-gl-config
set-gl-config
@ -313,7 +313,7 @@
get-width
get-height
get-depth)
(define-class button% item% #f
(define-class button% item% () #f
set-border
set-label
on-drop-file
@ -322,7 +322,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class choice% item% #f
(define-class choice% item% () #f
set-selection
get-selection
number
@ -335,7 +335,7 @@
on-set-focus
on-kill-focus)
(define-function set-combo-box-font)
(define-class check-box% item% #f
(define-class check-box% item% () #f
set-label
set-value
get-value
@ -345,7 +345,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class canvas% window% #f
(define-class canvas% window% () #f
on-drop-file
pre-on-event
pre-on-char
@ -373,7 +373,7 @@
on-char
on-event
on-paint)
(define-private-class dc% dc<%> object% #f
(define-private-class dc% dc<%> object% () #f
get-alpha
set-alpha
glyph-exists?
@ -427,7 +427,7 @@
clear)
(define-function draw-tab)
(define-function draw-tab-base)
(define-class bitmap-dc% dc% ()
(define-class bitmap-dc% dc% () ()
get-bitmap
set-bitmap
draw-bitmap-section-smooth
@ -435,13 +435,13 @@
get-argb-pixels
set-pixel
get-pixel)
(define-class post-script-dc% dc% ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t]))
(define-class printer-dc% dc% ([parent #f]))
(define-private-class gl-context% gl-context<%> object% #f
(define-class post-script-dc% dc% () ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t]))
(define-class printer-dc% dc% () ([parent #f]))
(define-private-class gl-context% gl-context<%> object% () #f
call-as-current
swap-buffers
ok?)
(define-class gl-config% object% #f
(define-class gl-config% object% () #f
get-double-buffered
set-double-buffered
get-stereo
@ -454,23 +454,23 @@
set-depth-size
get-multisample-size
set-multisample-size)
(define-class event% object% ([time-stamp 0])
(define-class event% object% () ([time-stamp 0])
get-time-stamp
set-time-stamp)
(define-class control-event% event% (event-type [time-stamp 0])
(define-class control-event% event% () (event-type [time-stamp 0])
get-event-type
set-event-type)
(define-class popup-event% control-event% #f
(define-class popup-event% control-event% () #f
get-menu-id
set-menu-id)
(define-class scroll-event% event% ([event-type thumb] [direction vertical] [position 0] [time-stamp 0])
(define-class scroll-event% event% () ([event-type thumb] [direction vertical] [position 0] [time-stamp 0])
get-event-type
set-event-type
get-direction
set-direction
get-position
set-position)
(define-class key-event% event% ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f])
(define-class key-event% event% () ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f])
set-other-caps-key-code
get-other-caps-key-code
set-other-shift-altgr-key-code
@ -498,7 +498,7 @@
get-y
set-y)
(define-function key-symbol-to-integer)
(define-class mouse-event% event% (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f])
(define-class mouse-event% event% () (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f])
moving?
leaving?
entering?
@ -528,7 +528,7 @@
set-x
get-y
set-y)
(define-class frame% window% #f
(define-class frame% window% () #f
on-drop-file
pre-on-event
pre-on-char
@ -556,7 +556,7 @@
set-icon
iconize
set-title)
(define-class gauge% item% #f
(define-class gauge% item% () #f
get-value
set-value
get-range
@ -567,7 +567,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class font% object% #f
(define-class font% object% () #f
screen-glyph-exists?
get-font-id
get-size-in-pixels
@ -578,32 +578,32 @@
get-style
get-face
get-family)
(define-class font-list% object% #f
(define-class font-list% object% () #f
find-or-create-font)
(define-class color% object% #f
(define-class color% object% () #f
blue
green
red
set
ok?
copy-from)
(define-private-class color-database% color-database<%> object% #f
(define-private-class color-database% color-database<%> object% () #f
find-color)
(define-class point% object% #f
(define-class point% object% () #f
get-x
set-x
get-y
set-y)
(define-class brush% object% #f
(define-class brush% object% () #f
set-style
get-style
set-stipple
get-stipple
set-color
get-color)
(define-class brush-list% object% #f
(define-class brush-list% object% () #f
find-or-create-brush)
(define-class pen% object% #f
(define-class pen% object% () #f
set-style
get-style
set-stipple
@ -616,11 +616,11 @@
get-cap
set-width
get-width)
(define-class pen-list% object% #f
(define-class pen-list% object% () #f
find-or-create-pen)
(define-class cursor% object% #f
(define-class cursor% object% () #f
ok?)
(define-class region% object% (dc)
(define-class region% object% () (dc)
in-region?
is-empty?
get-bounding-box
@ -635,7 +635,7 @@
set-rounded-rectangle
set-rectangle
get-dc)
(define-class dc-path% object% #f
(define-class dc-path% object% () #f
get-bounding-box
append
reverse
@ -653,7 +653,7 @@
open?
close
reset)
(define-private-class font-name-directory% font-name-directory<%> object% #f
(define-private-class font-name-directory% font-name-directory<%> object% () #f
find-family-default-font-id
find-or-create-font-id
get-family
@ -686,7 +686,7 @@
(define-function get-display-depth)
(define-function is-color-display?)
(define-function file-selector)
(define-class list-box% item% #f
(define-class list-box% item% () #f
get-label-font
set-string
set-first-visible-item
@ -710,7 +710,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class editor-canvas% canvas% #f
(define-class editor-canvas% canvas% () #f
on-char
on-event
on-paint
@ -741,7 +741,7 @@
set-editor
get-wheel-step
set-wheel-step)
(define-class editor-admin% object% #f
(define-class editor-admin% object% () #f
modified
refresh-delayed?
popup-menu
@ -753,9 +753,9 @@
get-max-view
get-view
get-dc)
(define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% #f
(define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% () #f
get-snip)
(define-class snip-admin% object% #f
(define-class snip-admin% object% () #f
modified
popup-menu
update-cursor
@ -769,7 +769,7 @@
get-view-size
get-dc
get-editor)
(define-class snip-class% object% #f
(define-class snip-class% object% () #f
reading-version
write-header
read-header
@ -778,13 +778,13 @@
set-classname
get-version
set-version)
(define-private-class snip-class-list% snip-class-list<%> object% #f
(define-private-class snip-class-list% snip-class-list<%> object% () #f
nth
number
add
find-position
find)
(define-class keymap% object% #f
(define-class keymap% object% () #f
remove-chained-keymap
chain-to-keymap
set-break-sequence-callback
@ -800,11 +800,11 @@
handle-key-event
set-double-click-interval
get-double-click-interval)
(define-class editor-wordbreak-map% object% #f
(define-class editor-wordbreak-map% object% () #f
get-map
set-map)
(define-function get-the-editor-wordbreak-map)
(define-class text% editor% #f
(define-class text% editor% () #f
call-clickback
remove-clickback
set-clickback
@ -958,7 +958,7 @@
on-event
copy-self-to
copy-self)
(define-class menu% object% #f
(define-class menu% object% () #f
select
get-font
set-width
@ -973,30 +973,30 @@
delete-by-position
delete
append)
(define-class menu-bar% object% #f
(define-class menu-bar% object% () #f
set-label-top
number
enable-top
delete
append)
(define-class menu-item% object% #f
(define-class menu-item% object% () #f
id)
(define-function id-to-menu-item)
(define-class editor-stream-in-base% object% #f
(define-class editor-stream-in-base% object% () #f
read
bad?
skip
seek
tell)
(define-class editor-stream-out-base% object% #f
(define-class editor-stream-out-base% object% () #f
write
bad?
seek
tell)
(define-class editor-stream-in-bytes-base% editor-stream-in-base% #f)
(define-class editor-stream-out-bytes-base% editor-stream-out-base% #f
(define-class editor-stream-in-bytes-base% editor-stream-in-base% () #f)
(define-class editor-stream-out-bytes-base% editor-stream-out-base% () #f
get-bytes)
(define-class editor-stream-in% object% #f
(define-class editor-stream-in% object% () #f
ok?
jump-to
tell
@ -1009,19 +1009,19 @@
get-unterminated-bytes
get-bytes
get)
(define-class editor-stream-out% object% #f
(define-class editor-stream-out% object% () #f
ok?
pretty-finish
jump-to
tell
put-fixed
put)
(define-class timer% object% ()
(define-class timer% object% () ()
stop
start
notify
interval)
(define-private-class clipboard% clipboard<%> object% #f
(define-private-class clipboard% clipboard<%> object% () #f
get-clipboard-bitmap
set-clipboard-bitmap
get-clipboard-data
@ -1030,12 +1030,12 @@
set-clipboard-client)
(define-function get-the-x-selection)
(define-function get-the-clipboard)
(define-class clipboard-client% object% ()
(define-class clipboard-client% object% () ()
get-types
add-type
get-data
on-replaced)
(define-class ps-setup% object% ()
(define-class ps-setup% object% () ()
copy-from
set-margin
set-editor-margin
@ -1061,7 +1061,7 @@
get-command)
(define-function show-print-setup)
(define-function can-show-print-setup?)
(define-class pasteboard% editor% #f
(define-class pasteboard% editor% () #f
set-scroll-step
get-scroll-step
set-selection-visible
@ -1177,7 +1177,7 @@
paste
copy
cut)
(define-class panel% window% #f
(define-class panel% window% () #f
get-label-position
set-label-position
on-char
@ -1191,7 +1191,7 @@
on-kill-focus
set-item-cursor
get-item-cursor)
(define-class dialog% window% #f
(define-class dialog% window% () #f
system-menu
set-title
on-drop-file
@ -1203,7 +1203,7 @@
enforce-size
on-close
on-activate)
(define-class radio-box% item% #f
(define-class radio-box% item% () #f
button-focus
enable
set-selection
@ -1215,7 +1215,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class slider% item% #f
(define-class slider% item% () #f
set-value
get-value
on-drop-file
@ -1224,7 +1224,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class snip% object% #f
(define-class snip% object% () #f
previous
next
set-unmodified
@ -1262,7 +1262,7 @@
get-style
get-snipclass
set-snipclass)
(define-class string-snip% snip% #f
(define-class string-snip% snip% () #f
read
insert
set-unmodified
@ -1289,7 +1289,7 @@
draw
partial-offset
get-extent)
(define-class tab-snip% string-snip% #f
(define-class tab-snip% string-snip% () #f
set-unmodified
get-scroll-step-offset
find-scroll-step
@ -1314,7 +1314,11 @@
draw
partial-offset
get-extent)
(define-class image-snip% snip% #f
(define-class image-snip% snip% (equal<%>) #f
equal-secondary-hash-code-of
equal-hash-code-of
other-equal-to?
equal-to?
set-offset
get-bitmap-mask
get-bitmap
@ -1346,7 +1350,7 @@
draw
partial-offset
get-extent)
(define-class editor-snip% snip% #f
(define-class editor-snip% snip% () #f
get-inset
set-inset
get-margin
@ -1393,23 +1397,23 @@
get-extent
set-editor
get-editor)
(define-class editor-data-class% object% #f
(define-class editor-data-class% object% () #f
read
get-classname
set-classname)
(define-private-class editor-data-class-list% editor-data-class-list<%> object% #f
(define-private-class editor-data-class-list% editor-data-class-list<%> object% () #f
nth
number
add
find-position
find)
(define-class editor-data% object% #f
(define-class editor-data% object% () #f
set-next
write
get-dataclass
set-dataclass
get-next)
(define-private-class mult-color% mult-color<%> object% #f
(define-private-class mult-color% mult-color<%> object% () #f
set
get
get-r
@ -1418,7 +1422,7 @@
set-g
get-b
set-b)
(define-private-class add-color% add-color<%> object% #f
(define-private-class add-color% add-color<%> object% () #f
set
get
get-r
@ -1427,7 +1431,7 @@
set-g
get-b
set-b)
(define-class style-delta% object% #f
(define-class style-delta% object% () #f
copy
collapse
equal?
@ -1475,7 +1479,7 @@
set-alignment-on
get-alignment-off
set-alignment-off)
(define-private-class style% style<%> object% #f
(define-private-class style% style<%> object% () #f
switch-to
set-shift-style
get-shift-style
@ -1502,7 +1506,7 @@
get-face
get-family
get-name)
(define-class style-list% object% #f
(define-class style-list% object% () #f
forget-notification
notify-on-change
style-to-index
@ -1516,7 +1520,7 @@
number
basic-style)
(define-function get-the-style-list)
(define-class tab-group% item% #f
(define-class tab-group% item% () #f
button-focus
set
set-label
@ -1532,7 +1536,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class group-box% item% #f
(define-class group-box% item% () #f
on-drop-file
pre-on-event
pre-on-char

152
collects/mrlib/cache-image-snip.ss
View File

@ -7,7 +7,11 @@
(provide cache-image-snip%
cache-image-snip-class%
snip-class)
snip-class
coerce-to-cache-image-snip
snip-size
bitmaps->cache-image-snip)
;; type argb = (make-argb (vectorof rational[between 0 & 255]) int int)
(define-struct argb (vector width height))
@ -40,7 +44,7 @@
|#
(define cache-image-snip%
(class snip%
(class image-snip%
;; dc-proc : (union #f ((is-a?/c dc<%>) int[dx] int[dy] -> void))
;; used for direct drawing
@ -85,7 +89,7 @@
;; get-bitmap : -> bitmap or false
;; returns a bitmap showing what the image would look like,
;; if it were drawn
(define/public (get-bitmap)
(define/override (get-bitmap)
(cond
[(or (zero? width) (zero? height))
#f]
@ -142,6 +146,15 @@
(define/override (find-scroll-step y) (inexact->exact (floor (/ y 20))))
(define/override (get-scroll-step-offset offset) (* offset 20))
(define/override (equal-to? snip recur)
(if (snip . is-a? . cache-image-snip%)
;; Support extensions of cache-image-snip%:
(send snip other-equal-to? this recur)
;; Use ths object's extension:
(other-equal-to? snip recur)))
(define/override (other-equal-to? snip recur)
(image=? this snip))
(super-new)
(inherit set-snipclass)
(set-snipclass snip-class)))
@ -215,6 +228,139 @@
(lambda (argb dx dy)
(overlay-bitmap argb size size dx dy bm bm)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; image equality
;;
(define size-dc (delay (make-object bitmap-dc% (make-object bitmap% 1 1))))
(define (snip-size a)
(cond
[(is-a? a cache-image-snip%)
(send a get-size)]
[else
(let* ([dc (force size-dc)]
[wb (box 0)]
[hb (box 0)])
(send a get-extent dc 0 0 wb hb #f #f #f #f)
(values (unbox wb)
(unbox hb)))]))
(define (image=? a-raw b-raw)
(let ([a (coerce-to-cache-image-snip a-raw)]
[b (coerce-to-cache-image-snip b-raw)])
(let-values ([(aw ah) (snip-size a)]
[(bw bh) (snip-size b)]
[(apx apy) (send a get-pinhole)]
[(bpx bpy) (send b get-pinhole)])
(and (= aw bw)
(= ah bh)
(= apx bpx)
(= apy bpy)
(same/alpha? (argb-vector (send a get-argb))
(argb-vector (send b get-argb)))))))
(define (same/alpha? v1 v2)
(let loop ([i (vector-length v1)])
(or (zero? i)
(let ([a1 (vector-ref v1 (- i 4))]
[a2 (vector-ref v2 (- i 4))])
(and (or (= a1 a2 255)
(and (= a1 a2)
(= (vector-ref v1 (- i 3)) (vector-ref v2 (- i 3)))
(= (vector-ref v1 (- i 2)) (vector-ref v2 (- i 2)))
(= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1)))))
(loop (- i 4)))))))
(define image-snip-cache (make-hash-table 'weak))
;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
(define (coerce-to-cache-image-snip snp)
(cond
[(is-a? snp cache-image-snip%) snp]
[(hash-table-get image-snip-cache snp (λ () #f)) => values]
[(is-a? snp image-snip%)
(let* ([bmp (send snp get-bitmap)]
[cis
(if bmp
(let ([bmp-mask (or (send bmp get-loaded-mask)
(send snp get-bitmap-mask)
(bitmap->mask bmp))])
(bitmaps->cache-image-snip (copy-bitmap bmp)
(copy-bitmap bmp-mask)
(floor (/ (send bmp get-width) 2))
(floor (/ (send bmp get-height) 2))))
(let-values ([(w h) (snip-size snp)])
(let* ([bmp (make-object bitmap%
(inexact->exact (floor w))
(inexact->exact (floor h)))]
[bdc (make-object bitmap-dc% bmp)])
(send snp draw bdc 0 0 0 0 w h 0 0 'no-caret)
(send bdc set-bitmap #f)
(bitmaps->cache-image-snip bmp
(bitmap->mask bmp)
(floor (/ w 2))
(floor (/ h 2))))))])
(hash-table-put! image-snip-cache snp cis)
cis)]
[else snp]))
;; copy-bitmap : bitmap -> bitmap
;; does not copy the mask.
(define (copy-bitmap bitmap)
(let* ([w (send bitmap get-width)]
[h (send bitmap get-height)]
[copy (make-object bitmap% w h)]
[a-dc (make-object bitmap-dc% copy)])
(send a-dc clear)
(send a-dc draw-bitmap bitmap 0 0)
(send a-dc set-bitmap #f)
copy))
;; bitmap->mask : bitmap -> bitmap
(define (bitmap->mask bitmap)
(let* ([w (send bitmap get-width)]
[h (send bitmap get-height)]
[s (make-bytes (* 4 w h))]
[new-bitmap (make-object bitmap% w h)]
[dc (make-object bitmap-dc% new-bitmap)])
(send dc clear)
(send dc draw-bitmap bitmap 0 0)
(send dc get-argb-pixels 0 0 w h s)
(let loop ([i (* 4 w h)])
(unless (zero? i)
(let ([r (- i 3)]
[g (- i 2)]
[b (- i 1)])
(unless (and (eq? 255 (bytes-ref s r))
(eq? 255 (bytes-ref s g))
(eq? 255 (bytes-ref s b)))
(bytes-set! s r 0)
(bytes-set! s g 0)
(bytes-set! s b 0))
(loop (- i 4)))))
(send dc set-argb-pixels 0 0 w h s)
(begin0
(send dc get-bitmap)
(send dc set-bitmap #f))))
(define (bitmaps->cache-image-snip color mask px py)
(let ([w (send color get-width)]
[h (send color get-height)])
(new cache-image-snip%
[width w]
[height h]
[dc-proc
(lambda (dc dx dy)
(send dc draw-bitmap color dx dy 'solid
(send the-color-database find-color "black")
mask))]
[argb-proc
(lambda (argb-vector dx dy)
(overlay-bitmap argb-vector dx dy color mask))]
[px px]
[py py])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; misc. utilities

31
collects/mrlib/scribblings/cache-image-snip.scrbl
View File

@ -16,7 +16,22 @@ bitmap, but with alpha values. It has a maker, two selectors, and a
predicate.
@defclass[cache-image-snip% snip% ()]{
@defclass[cache-image-snip% image-snip% ()]{
The @scheme[cache-image-snip%] class is a subclass of
@scheme[image-snip%] simply so that its instances can be compared with
@scheme[image-snip%] using @scheme[equal?]. All @scheme[image-snip%]
functionality is overridden or ignored.
@defmethod[#:mode overrride
(equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)])
boolean?]{
Calls the @method[cache-image-snip% other-equal-to?] method of
@scheme[snip] if it is also a @scheme[cache-image-snip%] instance,
otherwise calls the @method[cache-image-snip% other-equal-to?] of
@this-obj[].}
@defmethod[(get-argb)
@ -44,7 +59,8 @@ predicate.
}
@defmethod[(get-bitmap) (or/c false/c (is-a?/c bitmap%))]{
@defmethod[#:mode override
(get-bitmap) (or/c false/c (is-a?/c bitmap%))]{
Builds (if not yet built) a bitmap corresponding to
this snip and returns it.
@ -75,7 +91,15 @@ predicate.
Returns the width and height for the image.
}}
}
@defmethod[#:mode override
(other-equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)])
boolean?]{
Refines the comparison of @xmethod[image-snip% other-equal-to?] to
exactly match alpha channels.}}
@; ----------------------------------------
@ -83,6 +107,7 @@ predicate.
This snipclass is used for saved cache image snips.}
@defproc[(make-argb [vectorof (integer-in 0 255)]
[width exact-nonnegative-integer?]
[height exact-nonnegative-integer?])

34
collects/mzlib/private/unit-compiletime.ss
View File

@ -155,17 +155,17 @@
(raise-stx-err "not a unit definition" id))
u))
;; check-module-id-subset : (listof syntax-object) (listof identifier) syntax-object ->
;; ensures each element of i1 is an identifier module-identifier=? to an identifier in i2
(define (check-module-id-subset i1 i2)
(let ((ht (make-module-identifier-mapping)))
;; check-bound-id-subset : (listof syntax-object) (listof identifier) syntax-object ->
;; ensures each element of i1 is an identifier bound-identifier=? to an identifier in i2
(define (check-bound-id-subset i1 i2)
(let ((ht (make-bound-identifier-mapping)))
(for-each (lambda (id)
(module-identifier-mapping-put! ht id #t))
(bound-identifier-mapping-put! ht id #t))
i2)
(for-each
(lambda (id)
(check-id id)
(unless (module-identifier-mapping-get ht id (lambda () #f))
(unless (bound-identifier-mapping-get ht id (lambda () #f))
(raise-stx-err "listed identifier not present in signature specification" id)))
i1)))
@ -173,20 +173,20 @@
;; internals and externals must both be of the form (x ...)
;; ensures that each x above is an identifier
(define (do-rename sig internals externals)
(check-module-id-subset (syntax->list externals)
(check-bound-id-subset (syntax->list externals)
(sig-int-names sig))
(let ((ht (make-module-identifier-mapping)))
(let ((ht (make-bound-identifier-mapping)))
(for-each
(lambda (int ext)
(check-id int)
(when (module-identifier-mapping-get ht ext (lambda () #f))
(when (bound-identifier-mapping-get ht ext (lambda () #f))
(raise-stx-err "duplicate renamings" ext))
(module-identifier-mapping-put! ht ext int))
(bound-identifier-mapping-put! ht ext int))
(syntax->list internals)
(syntax->list externals))
(map-sig
(lambda (id)
(module-identifier-mapping-get ht id (lambda () id)))
(bound-identifier-mapping-get ht id (lambda () id)))
(lambda (x) x)
sig)))
@ -203,17 +203,17 @@
;; do-only/except : sig (listof identifier) -> sig
;; ensures that only-ids are identifiers and are mentioned in the signature
(define (do-only/except sig only/except-ids put get)
(check-module-id-subset only/except-ids
(check-bound-id-subset only/except-ids
(sig-int-names sig))
(let ((ht (make-module-identifier-mapping)))
(let ((ht (make-bound-identifier-mapping)))
(for-each (lambda (id)
(module-identifier-mapping-put! ht id (put id)))
(bound-identifier-mapping-put! ht id (put id)))
only/except-ids)
(map-sig
(lambda (id)
(module-identifier-mapping-get ht id
(lambda ()
(get id))))
(bound-identifier-mapping-get ht id
(lambda ()
(get id))))
(lambda (x) x)
sig)))

10
collects/net/url-unit.ss
View File

@ -378,13 +378,9 @@
(eq? 'windows (file-url-path-convention-type))
(not (equal? host "")))])
(when win-file?
(if (equal? "" port)
(set! path (string-append host ":" path))
(set! path (if path
(if host
(string-append host "/" path)
path)
host)))
(set! path (cond [(equal? "" port) (string-append host ":" path)]
[(and path host) (string-append host "/" path)]
[else (or path host)]))
(set! port #f)
(set! host ""))
(let* ([scheme (and scheme (string-downcase scheme))]

2
collects/r5rs/main.ss
View File

@ -164,6 +164,8 @@
;; quote has to create mpairs:
(syntax-local-lift-expression (let loop ([form #'form])
(syntax-case form ()
[(a ...)
#`(mlist . #,(map loop (syntax->list #'(a ...))))]
[(a . b)
#`(mcons #,(loop #'a) #,(loop #'b))]
[#(a ...)

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

@ -11,8 +11,10 @@
(require (for-syntax (lib "name.ss" "syntax")
"rewrite-side-conditions.ss"
"term-fn.ss"
"underscore-allowed.ss"
(lib "boundmap.ss" "syntax")
scheme/base))
scheme/base
(prefix-in pattern- scheme/match)))
(define (language-nts lang)
(hash-map (compiled-lang-ht lang) (λ (x y) x)))
@ -440,16 +442,17 @@
(syntax->list (syntax (extras ...)))
lang-id))]
[((rhs-arrow rhs-from rhs-to) (lhs-arrow lhs-frm-id lhs-to-id))
(let ([lang-nts (language-id-nts lang-id orig-name)])
(let* ([lang-nts (language-id-nts lang-id orig-name)]
[rewrite-side-conds
(λ (pat) (rewrite-side-conditions/check-errs lang-nts orig-name #t pat))])
(let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t (syntax rhs-from))])
(with-syntax ([(names ...) names]
[(names/ellipses ...) names/ellipses]
[side-conditions-rewritten (rewrite-side-conditions/check-errs
lang-nts
orig-name
#t
[side-conditions-rewritten (rewrite-side-conds
(rewrite-node-pat (syntax-e (syntax lhs-frm-id))
(syntax->datum (syntax rhs-from))))]
(syntax rhs-from)))]
[fresh-rhs-from (rewrite-side-conds
(freshen-names #'rhs-from #'lhs-frm-id lang-nts orig-name))]
[lang lang])
(map
(λ (child-proc)
@ -460,19 +463,51 @@
(λ (bindings rhs-binder)
(term-let ([lhs-to-id rhs-binder]
[names/ellipses (lookup-binding bindings 'names)] ...)
(term rhs-to)))
#,child-proc))
(term rhs-to)))
#,child-proc
`fresh-rhs-from))
(get-choices stx orig-name bm #'lang
(syntax lhs-arrow)
name-table lang-id
allow-zero-rules?)))))]))
(define (rewrite-node-pat id term)
(let loop ([term term])
(cond
[(eq? id term) `(name ,id any)]
[(pair? term) (cons (loop (car term))
(loop (cdr term)))]
[else term])))
(let loop ([t term])
(syntax-case t (side-condition)
[(side-condition p c)
#`(side-condition #,(loop #'p) c)]
[(p ...)
(map loop (syntax->list #'(p ...)))]
[else
(if (and (identifier? t) (eq? id (syntax-e t)))
`(name ,id any)
t)])))
(define (freshen-names pat hole-id nts what)
(define (fresh x)
(gensym
(if (or (memq x nts) (memq x underscore-allowed))
(string-append (symbol->string x) "_")
x)))
(let-values ([(bound _) (extract-names nts what #t pat #f)])
(let ([renames (make-bound-identifier-mapping)])
(for-each
(λ (x)
(unless (bound-identifier=? x hole-id)
(bound-identifier-mapping-put! renames x (fresh (syntax-e x)))))
bound)
(let recur ([p pat])
(syntax-case p (side-condition)
[(side-condition p c)
#`(side-condition
#,(recur #'p)
(term-let (#,@(bound-identifier-mapping-map renames (λ (x y) #`(#,x (term #,y)))))
c))]
[(p ...)
#`(#,@(map recur (syntax->list #'(p ...))))]
[else
(if (identifier? p)
(bound-identifier-mapping-get renames p (λ () p))
p)])))))
(define (do-leaf stx orig-name lang name-table from to extras lang-id)
(let ([lang-nts (language-id-nts lang-id orig-name)])
@ -484,7 +519,7 @@
orig-name
#t
from)]
[to to]
[to to #;#`,(begin (printf "~s\n" #,name) (term #,to))]
[name name]
[lang lang]
[(names ...) names]
@ -639,6 +674,18 @@
(cons (format " ~s" (syntax->datum (car stxs)))
(loop (cdr stxs)))])))))
(define (substitute from to pat)
(let recur ([p pat])
(syntax-case p (side-condition)
[(side-condition p c)
#`(side-condition #,(recur #'p) c)]
[(p ...)
#`(#,@(map recur (syntax->list #'(p ...))))]
[else
(if (and (identifier? p) (bound-identifier=? p from))
to
p)])))
(define (verify-name-ok orig-name the-name)
(unless (symbol? the-name)
(error orig-name "expected a single name, got ~s" the-name)))
@ -679,7 +726,12 @@
(apply append (map reduction-relation-lws lst))
`any)))
(define (do-node-match lhs-frm-id lhs-to-id pat rhs-proc child-make-proc)
(define (do-node-match lhs-frm-id lhs-to-id pat rhs-proc child-make-proc rhs-from)
(define (subst from to in)
(let recur ([p in])
(cond [(eq? from p) to]
[(pair? p) (map recur p)]
[else p])))
;; need call to make-rewrite-proc
;; also need a test case here to check duplication of names.
(make-rewrite-proc
@ -701,7 +753,8 @@
(λ (x) (f (rhs-proc (mtch-bindings (car mtchs)) x)))
acc)))]))
other-matches)))))
(rewrite-proc-name child-make-proc)))
(rewrite-proc-name child-make-proc)
(subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)))
(define (do-leaf-match name pat proc)
(make-rewrite-proc
@ -717,7 +770,8 @@
mtchs
other-matches)
other-matches)))))
name))
name
pat))
(define-syntax (test-match stx)
(syntax-case stx ()
@ -758,7 +812,7 @@
(symbol->string (bind-name y))))))
(define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!)
(make-struct-type 'metafunc-proc #f 9 0 #f null (current-inspector) 0))
(make-struct-type 'metafunc-proc #f 10 0 #f null (current-inspector) 0))
(define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 1))
(define metafunc-proc-lang (make-struct-field-accessor metafunc-proc-ref 2))
(define metafunc-proc-multi-arg? (make-struct-field-accessor metafunc-proc-ref 3))
@ -767,6 +821,7 @@
(define metafunc-proc-rhss (make-struct-field-accessor metafunc-proc-ref 6))
(define metafunc-proc-in-dom? (make-struct-field-accessor metafunc-proc-ref 7))
(define metafunc-proc-dom-pat (make-struct-field-accessor metafunc-proc-ref 8))
(define metafunc-proc-lhs-pats (make-struct-field-accessor metafunc-proc-ref 9))
(define-struct metafunction (proc))
(define-syntax (in-domain? stx)
@ -937,7 +992,8 @@
cps
rhss
(let ([name (lambda (x) (name-predicate x))]) name)
`dom-side-conditions-rewritten))
`dom-side-conditions-rewritten
`(side-conditions-rewritten ...)))
`dom-side-conditions-rewritten
`codom-side-conditions-rewritten
'name))
@ -1714,6 +1770,7 @@
metafunc-proc-rhss
metafunc-proc-in-dom?
metafunc-proc-dom-pat
metafunc-proc-lhs-pats
(struct-out binds))

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

@ -1,9 +1,10 @@
(module rewrite-side-conditions mzscheme
(module rewrite-side-conditions scheme/base
(require (lib "list.ss")
"underscore-allowed.ss")
(require-for-template mzscheme
"term.ss"
"matcher.ss")
(require (for-template
mzscheme
"term.ss"
"matcher.ss"))
(provide rewrite-side-conditions/check-errs
extract-names
@ -85,7 +86,7 @@
(define-struct id/depth (id depth))
;; extract-names : syntax syntax -> (values (listof syntax) (listof syntax[x | (x ...) | ((x ...) ...) | ...]))
(define (extract-names all-nts what bind-names? orig-stx)
(define (extract-names all-nts what bind-names? orig-stx [rhs-only? #t])
(let* ([dups
(let loop ([stx orig-stx]
[names null]
@ -115,8 +116,8 @@
[else
(if (or (null? (cdr pats))
(not (identifier? (cadr pats)))
(not (or (module-identifier=? (quote-syntax ...)
(cadr pats))
(not (or (free-identifier=? (quote-syntax ...)
(cadr pats))
(let ([inside (syntax-e (cadr pats))])
(regexp-match #rx"^\\.\\.\\._" (symbol->string inside))))))
(i-loop (cdr pats)
@ -125,7 +126,8 @@
(loop (car pats) names (+ depth 1))))]))]
[x
(and (identifier? (syntax x))
(binds-in-right-hand-side? all-nts bind-names? (syntax x)))
((if rhs-only? binds-in-right-hand-side? binds?)
all-nts bind-names? (syntax x)))
(cons (make-id/depth (syntax x) depth) names)]
[else names]))]
[no-dups (filter-duplicates what orig-stx dups)])
@ -141,14 +143,16 @@
[dots (quote-syntax ...)])
(syntax (rest dots)))])))
(define (binds-in-right-hand-side? nts bind-names? x)
(define (binds? nts bind-names? x)
(or (and bind-names? (memq (syntax-e x) nts))
(and bind-names? (memq (syntax-e x) underscore-allowed))
(let ([str (symbol->string (syntax-e x))])
(and (regexp-match #rx"_" str)
(not (regexp-match #rx"^\\.\\.\\._" str))
(not (regexp-match #rx"_!_" str))))))
(regexp-match #rx"_" (symbol->string (syntax-e x)))))
(define (binds-in-right-hand-side? nts bind-names? x)
(and (binds? nts bind-names? x)
(let ([str (symbol->string (syntax-e x))])
(and (not (regexp-match #rx"^\\.\\.\\._" str))
(not (regexp-match #rx"_!_" str))))))
(define (filter-duplicates what orig-stx dups)
(let loop ([dups dups])
@ -158,8 +162,8 @@
(cons
(car dups)
(filter (lambda (x)
(let ([same-id? (module-identifier=? (id/depth-id x)
(id/depth-id (car dups)))])
(let ([same-id? (free-identifier=? (id/depth-id x)
(id/depth-id (car dups)))])
(when same-id?
(unless (equal? (id/depth-depth x)
(id/depth-depth (car dups)))
@ -167,7 +171,7 @@
(make-exn:fail:syntax
(format "~a: found the same binder, ~s, at different depths, ~a and ~a"
what
(syntax-object->datum (id/depth-id x))
(syntax->datum (id/depth-id x))
(id/depth-depth x)
(id/depth-depth (car dups)))
(current-continuation-marks)

162
collects/redex/private/rg-test.ss
View File

@ -90,6 +90,21 @@
(test (pick-char 0 null (make-random 65)) #\a)
(test (random-string null null 1 0 (make-random 65)) "a"))
(let ()
(define-language L
(a 5 (x a) #:binds x a)
(b 4))
(test ((pick-nt 'dontcare) 'a L '(x) 1)
(nt-rhs (car (compiled-lang-lang L))))
(test ((pick-nt 'dontcare (make-random 1)) 'a L '(x) preferred-production-threshold)
(nt-rhs (car (compiled-lang-lang L))))
(let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
(test ((pick-nt (make-immutable-hash `((a ,pref))) (make-random 0))
'a L '(x) preferred-production-threshold)
(list pref)))
(test ((pick-nt 'dontcare) 'sexp sexp null preferred-production-threshold)
(nt-rhs (car (compiled-lang-lang sexp)))))
(define-syntax exn:fail-message
(syntax-rules ()
[(_ expr)
@ -101,7 +116,9 @@
(make-exn-not-raised))))]))
(define (patterns . selectors)
(map (λ (selector) (λ (name prods vars size) (list (selector prods))))
(map (λ (selector)
(λ (name lang vars size)
(list (selector (nt-rhs (nt-by-name lang name))))))
selectors))
(define (iterator name items)
@ -145,7 +162,7 @@
;; Generate (λ (x) x)
(test
(generate/decisions
(generate-term
lc e 1 0
(decisions #:var (list (λ _ 'x) (λ _'x))
#:nt (patterns third first first first)))
@ -153,14 +170,14 @@
;; Generate pattern that's not a non-terminal
(test
(generate/decisions
(generate-term
lc (x x x_1 x_1) 1 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
'(x x y y))
; After choosing (e e), size decremented forces each e to x.
(test
(generate/decisions
(generate-term
lc e 1 0
(decisions #:nt (patterns first)
#:var (list (λ _ 'x) (λ _ 'y))))
@ -176,7 +193,7 @@
(let* ([x null]
[prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))])
(test (begin
(generate/decisions lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!)))
(generate-term lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!)))
x)
'(x x))))
@ -187,7 +204,7 @@
(x (variable-except λ)))
(test
(exn:fail-message
(generate/decisions
(generate-term
postfix e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))
#:nt (patterns third second first first))))
@ -198,7 +215,7 @@
(define-language var
(e (variable-except x y)))
(test
(generate/decisions
(generate-term
var e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z))))
'z))
@ -215,25 +232,25 @@
(n number)
(z 4))
(test
(generate/decisions
(generate-term
lang a 2 0
(decisions #:num (build-list 3 (λ (n) (λ (_) n)))
#:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 1))))
`(0 1 2 "foo" "foo" "foo" "bar" #t))
(test (generate/decisions lang b 5 0 (decisions #:seq (list (λ (_) 0))))
(test (generate-term lang b 5 0 (decisions #:seq (list (λ (_) 0))))
null)
(test (generate/decisions lang c 5 0 (decisions #:seq (list (λ (_) 0))))
(test (generate-term lang c 5 0 (decisions #:seq (list (λ (_) 0))))
null)
(test (generate/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2))))
(test (generate-term lang d 5 0 (decisions #:seq (list (λ (_) 2))))
'(4 4 4 4 (4 4) (4 4)))
(test (exn:fail-message (generate lang e 5))
(test (exn:fail-message (generate-term lang e 5))
#rx"generate: unable to generate pattern e")
(test (generate/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null)
(test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(test (generate-term lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null)
(test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4)
(λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3))))
'((0 0 0) (0 0 0 0) (1 1 1)))
(test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5))))
'((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1))))
@ -247,7 +264,7 @@
;; x and y bound in body
(test
(let/ec k
(generate/decisions
(generate-term
lc e 10 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))
#:nt (patterns first first first third first)
@ -257,7 +274,7 @@
(let ()
(define-language lang (e (variable-prefix pf)))
(test
(generate/decisions
(generate-term
lang e 5 0
(decisions #:var (list (λ _ 'x))))
'pfx))
@ -271,7 +288,7 @@
(define-language lang
(e number (e_1 e_2 e e_1 e_2)))
(test
(generate/decisions
(generate-term
lang e 5 0
(decisions #:nt (patterns second first first first)
#:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
@ -283,7 +300,7 @@
(x variable))
(test
(let/ec k
(generate/decisions
(generate-term
lang e 5 0
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x)))
@ -294,17 +311,17 @@
(b (c_!_1 c_!_1 c_!_1))
(c 1 2))
(test
(generate/decisions
(generate-term
lang a 5 0
(decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2))))
'(1 1 2))
(test
(generate/decisions
(generate-term
lang (number_!_1 number_!_2 number_!_1) 5 0
(decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2))))
'(1 1 2))
(test
(exn:fail-message (generate lang b 5000))
(exn:fail-message (generate-term lang b 5000))
#rx"unable"))
(let ()
@ -313,7 +330,7 @@
(f foo bar))
(test
(let/ec k
(generate/decisions
(generate-term
lang e 5 0
(decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?))))))))
(cons '(#\a #\b #\f #\o #\r)
@ -327,28 +344,28 @@
(d (side-condition (x_1 x_1 x) (not (eq? (term x_1) 'x))) #:binds x_1 x)
(e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x))))
(x variable))
(test (generate lang b 5) 43)
(test (generate lang (side-condition a (odd? (term a))) 5) 43)
(test (exn:fail-message (generate lang c 5))
(test (generate-term lang b 5) 43)
(test (generate-term lang (side-condition a (odd? (term a))) 5) 43)
(test (exn:fail-message (generate-term lang c 5))
#rx"unable to generate")
(test ; binding works for with side-conditions failure/retry
(let/ec k
(generate/decisions
(generate-term
lang d 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))))))
'(y))
(test ; mismatch patterns work with side-condition failure/retry
(generate/decisions
(generate-term
lang e 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y))))
'(y x y))
(test ; generate compiles side-conditions in pattern
(generate/decisions lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
(generate-term lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
'y)
(test ; bindings within ellipses collected properly
(let/ec k
(generate/decisions lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0
(generate-term lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4))
#:num (build-list 7 (λ (n) (λ (_) n))))))
'((0 1 2) (3 4 5 6))))
@ -360,9 +377,9 @@
(c (side-condition (name x d) (zero? (term x))))
(d 2 1 0)
(e ((side-condition (name d_1 d) (zero? (term d_1))) d_1)))
(test (generate lang a 5) 4)
(test (generate lang c 5) 0)
(test (generate lang e 5) '(0 0)))
(test (generate-term lang a 5) 4)
(test (generate-term lang c 5) 0)
(test (generate-term lang e 5) '(0 0)))
(let ()
(define-language lang
@ -380,28 +397,28 @@
(y variable))
(test
(generate/decisions
(generate-term
lang (in-hole A number ) 5 0
(decisions
#:nt (patterns second second first first third first second first first)
#:num (build-list 5 (λ (x) (λ (_) x)))))
'(+ (+ 1 2) (+ 0 (+ 3 4))))
(test (generate lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5))
(test (generate lang (hole 4) 5) (term (hole 4)))
(test (generate/decisions lang (variable_1 (in-hole C variable_1)) 5 0
(test (generate-term lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5))
(test (generate-term lang (hole 4) 5) (term (hole 4)))
(test (generate-term lang (variable_1 (in-hole C variable_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x))))
'(x x))
(test (generate/decisions lang (variable_!_1 (in-hole C variable_!_1)) 5 0
(test (generate-term lang (variable_!_1 (in-hole C variable_!_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y))))
'(x y))
(test (let/ec k (generate/decisions lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
(test (let/ec k (generate-term lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x))
(test (generate/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2))))
(test (generate-term lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2))))
'((2 (1 1)) 1))
(test (generate/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
(test (generate-term lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
'(1 0))
(test (generate/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3))))
(test (generate-term lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3))))
'((2 ((3 (2 1)) 3)) 1)))
(let ()
@ -409,7 +426,7 @@
(e (e e) (+ e e) x v)
(v (λ (x) e) number)
(x variable-not-otherwise-mentioned))
(test (generate/decisions lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x))))
(test (generate-term lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x))))
'x))
(let ()
@ -423,14 +440,14 @@
(list four 'f))
(test (call-with-values (λ () (pick-any four (make-random 1))) list)
(list sexp 'sexp))
(test (generate/decisions four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4)
(test (generate/decisions four any 5 0
(test (generate-term four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4)
(test (generate-term four any 5 0
(decisions #:any (list (λ _ (values sexp 'sexp)))
#:nt (patterns fifth second second second)
#:seq (list (λ _ 3))
#:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz"))))
'("foo" "bar" "baz"))
(test (generate/decisions empty any 5 0 (decisions #:nt (patterns first)
(test (generate-term empty any 5 0 (decisions #:nt (patterns first)
#:var (list (λ _ 'x))))
'x))
@ -438,7 +455,7 @@
(let ()
(define-language lang
(e (hide-hole (in-hole ((hide-hole hole) hole) 1))))
(test (generate lang e 5) (term (hole 1))))
(test (generate-term lang e 5) (term (hole 1))))
(define (output-error-port thunk)
(let ([port (open-output-string)])
@ -452,14 +469,11 @@
(e x (e e) v)
(v (λ (x) e))
(x variable-not-otherwise-mentioned))
(test (generate/decisions lang (cross e) 3 0
(test (generate-term lang (cross e) 3 0
(decisions #:nt (patterns fourth first first second first first first)
#:var (list (λ _ 'x) (λ _ 'y))))
(term (λ (x) (hole y)))))
; preferred productions
;; current-error-port-output : (-> (-> any) string)
(define (current-error-port-output thunk)
(let ([p (open-output-string)])
@ -521,6 +535,52 @@
;; OK -- generated from pattern (any ...)
(test (check-metafunction-contract i) #t))
;; check-reduction-relation
(let ()
(define-language L
(e (+ e ...) number)
(E (+ number ... E* e ...))
(E* hole E*))
(define R
(reduction-relation
L
(==> (+ number ...) whatever)
(--> (side-condition number (even? (term number))) whatever)
with
[(--> (in-hole E a) whatever)
(==> a b)]))
(let ([generated null])
(test (begin
(check-reduction-relation
R (λ (term) (set! generated (cons term generated)))
#:decisions (decisions #:seq (list (λ _ 0) (λ _ 0) (λ _ 0))
#:num (list (λ _ 1) (λ _ 1) (λ _ 0)))
#:attempts 1)
generated)
(reverse '((+ (+)) 0))))
(let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
(test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t)
(test (current-error-port-output
(λ () (check-reduction-relation S (λ (x) #f))))
"checking name failed after 1 attempts:\n1\n")
(test (current-error-port-output
(λ () (check-reduction-relation S (curry eq? 1))))
"checking unnamed failed after 1 attempts:\n3\n")))
; check-metafunction
(let ()
(define-language empty)
(define-metafunction empty
[(m 1) whatever]
[(m 2) whatever])
(let ([generated null])
(test (begin
(check-metafunction m (λ (t) (set! generated (cons t generated))) 1)
generated)
(reverse '((1) (2)))))
(test (current-error-port-output (λ () (check-metafunction m (curry eq? 1))))
#rx"checking clause #1 failed after 1 attempt"))
;; parse/unparse-pattern
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])
(define-language lang (x variable))

173
collects/redex/private/rg.ss
View File

@ -20,6 +20,7 @@ To do a better job of not generating programs with free variables,
"underscore-allowed.ss"
"term.ss"
"error.ss"
"struct.ss"
(for-syntax "rewrite-side-conditions.ss")
(for-syntax "term-fn.ss")
(for-syntax "reduction-semantics.ss")
@ -83,13 +84,16 @@ To do a better job of not generating programs with free variables,
(define (pick-string lang-chars lang-lits attempt [random random])
(random-string lang-chars lang-lits (random-natural 1/5 random) attempt random))
(define ((pick-nt pref-prods) nt prods bound-vars attempt)
(let* ([binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)]
(define ((pick-nt pref-prods [random random]) name lang bound-vars attempt)
(let* ([prods (nt-rhs (nt-by-name lang name))]
[binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)]
[do-intro-binder? (and (null? bound-vars)
(not (null? binders))
(try-to-introduce-binder?))])
(cond [do-intro-binder? binders]
[(preferred-production? attempt) (list (hash-ref pref-prods nt))]
[(and (not (eq? lang sexp))
(preferred-production? attempt random))
(hash-ref pref-prods name)]
[else prods])))
(define (pick-from-list l [random random]) (list-ref l (random (length l))))
@ -155,7 +159,7 @@ To do a better job of not generating programs with free variables,
[zip (λ (l m) (map cons l m))])
(map cdr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt))))))
(define (generate* lang pat decisions@)
(define (generate lang decisions@)
(define-values/invoke-unit decisions@
(import) (export decisions^))
@ -165,18 +169,15 @@ To do a better job of not generating programs with free variables,
(define (generate-nt name fvt-id bound-vars size attempt in-hole state)
(let*-values
([(nt) (findf (λ (nt) (eq? name (nt-name nt)))
(append (compiled-lang-lang lang)
(compiled-lang-cclang lang)))]
[(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
([(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
[(term _)
(generate/pred
name
(λ ()
(let ([rhs (pick-from-list
(if (zero? size)
(min-prods nt base-table)
((next-non-terminal-decision) name (nt-rhs nt) bound-vars attempt)))])
(min-prods (nt-by-name lang name) base-table)
((next-non-terminal-decision) name lang bound-vars attempt)))])
(((generate-pat bound-vars (max 0 (sub1 size)) attempt) (rhs-pattern rhs) in-hole)
(make-state (map fvt-entry (rhs-var-info rhs)) #hash()))))
(λ (_ env) (mismatches-satisfied? env)))])
@ -289,7 +290,7 @@ To do a better job of not generating programs with free variables,
[`(hide-hole ,pattern) ((recur pattern the-hole) state)]
[`any
(let*-values ([(lang nt) ((next-any-decision) lang)]
[(term _) ((generate* lang nt decisions@) size attempt)])
[(term _) (((generate lang decisions@) nt) size attempt)])
(values term state))]
[(? (is-nt? lang))
(generate-nt pat pat bound-vars size attempt in-hole state)]
@ -355,15 +356,17 @@ To do a better job of not generating programs with free variables,
(state-fvt state))
(state-env state)))
(λ (size attempt)
(let-values ([(term state)
(generate/pred
(unparse-pattern pat)
(λ ()
(((generate-pat null size attempt) pat the-hole)
(make-state null #hash())))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (bindings (state-env state))))))
(λ (pat)
(let ([unparsed (unparse-pattern pat)])
(λ (size attempt)
(let-values ([(term state)
(generate/pred
unparsed
(λ ()
(((generate-pat null size attempt) pat the-hole)
(make-state null #hash())))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (bindings (state-env state))))))))
;; find-base-cases : compiled-language -> hash-table
(define (find-base-cases lang)
@ -446,6 +449,12 @@ To do a better job of not generating programs with free variables,
(define (built-in? x)
(and (memq x underscore-allowed) #t))
;; nt-by-name : lang symbol -> nt
(define (nt-by-name lang name)
(findf (λ (nt) (eq? name (nt-name nt)))
(append (compiled-lang-lang lang)
(compiled-lang-cclang lang))))
(define named-nt-rx #rx"^([^_]+)_[^_]*$")
(define mismatch-nt-rx #rx"([^_]+)_!_[^_]*$")
(define named-ellipsis-rx #rx"^\\.\\.\\._[^_]*$")
@ -591,7 +600,7 @@ To do a better job of not generating programs with free variables,
[(struct ellipsis (name sub-pat class vars))
(make-ellipsis name (recur sub-pat) (rewrite class)
(map (λ (v) (if (class? v) (rewrite v) v)) vars))]
[(? list?) (map (λ (p) (recur p)) pat)]
[(? list?) (map recur pat)]
[_ pat]))))
;; used in generating the `any' pattern
@ -610,15 +619,16 @@ To do a better job of not generating programs with free variables,
(with-syntax ([(name ...) names]
[(name/ellipses ...) names/ellipses])
(syntax/loc stx
(check-property
(term-generator lang pat random-decisions)
(λ (_ bindings)
(with-handlers ([exn:fail? (λ (_) #f)])
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
property)))
attempts))))]))
(or (check-property
(term-generator lang pat random-decisions)
(λ (_ bindings)
(with-handlers ([exn:fail? (λ (_) #f)])
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
property)))
attempts)
(void)))))]))
(define (check-property generate property attempts)
(define (check-property generate property attempts [source #f])
(let loop ([remaining attempts])
(if (zero? remaining)
#t
@ -628,23 +638,21 @@ To do a better job of not generating programs with free variables,
(if (property term bindings)
(loop (sub1 remaining))
(begin
(fprintf (current-error-port)
"failed after ~s attempts:\n"
attempt)
(pretty-print term (current-error-port)))))))))
(when source
(fprintf (current-error-port) "checking ~a " source))
(fprintf (current-error-port) "failed after ~s attempts:\n" attempt)
(pretty-print term (current-error-port))
#f)))))))
(define-syntax generate
(define-syntax generate-term
(syntax-rules ()
[(_ lang pat size attempt)
(let-values ([(term _) ((term-generator lang pat random-decisions) size attempt)])
[(_ lang pat size attempt decisions)
(let-values ([(term _) ((term-generator lang pat decisions) size attempt)])
term)]
[(_ lang pat size) (generate lang pat size 0)]))
(define-syntax generate/decisions
(syntax-rules ()
[(_ lang pat size attempt decisions@)
(let-values ([(term _) ((term-generator lang pat decisions@) size attempt)])
term)]))
[(_ lang pat size attempt)
(generate-term lang pat size attempt random-decisions)]
[(_ lang pat size)
(generate-term lang pat size 1)]))
(define-syntax (term-generator stx)
(syntax-case stx ()
@ -655,10 +663,14 @@ To do a better job of not generating programs with free variables,
'generate #t #'pat)])
(syntax/loc stx
(let ([lang (parse-language lang)])
(generate*
lang
(reassign-classes (parse-pattern `pattern lang 'top-level))
(decisions lang)))))]))
((generate lang (decisions lang))
(reassign-classes (parse-pattern `pattern lang 'top-level))))))]))
(define-for-syntax (metafunc name stx)
(let ([tf (syntax-local-value name (λ () #f))])
(if (term-fn? tf)
(term-fn-get-id tf)
(raise-syntax-error #f "not a metafunction" stx name))))
(define-syntax (check-metafunction-contract stx)
(syntax-case stx ()
@ -666,22 +678,64 @@ To do a better job of not generating programs with free variables,
(syntax/loc stx (check-metafunction-contract name random-decisions))]
[(_ name decisions)
(identifier? #'name)
(with-syntax ([m (let ([tf (syntax-local-value #'name (λ () #f))])
(if (term-fn? tf)
(term-fn-get-id tf)
(raise-syntax-error #f "not a metafunction" stx #'name)))])
(with-syntax ([m (metafunc #'name stx)])
(syntax/loc stx
(let ([lang (parse-language (metafunc-proc-lang m))]
[dom (metafunc-proc-dom-pat m)])
(check-property
(generate* lang
(reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level))
(decisions lang))
((generate lang (decisions lang))
(reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level)))
(λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)])
(begin (term (name ,@t)) #t)))
default-check-attempts))))]))
(define (check-property-many lang patterns ids prop decisions attempts)
(let* ([lang-gen (generate lang (decisions lang))]
[pat-gens (map (λ (pat) (lang-gen (reassign-classes (parse-pattern pat lang 'top-level))))
patterns)])
(for/and ([pat patterns]
[id ids])
(check-property
(let ([gen (lang-gen (reassign-classes (parse-pattern pat lang 'top-level)))])
(λ (size attempt) (gen size attempt)))
(λ (term _) (prop term))
attempts
id))))
(define-syntax (check-metafunction stx)
(syntax-case stx ()
[(_ name property)
(syntax/loc stx (check-metafunction name property default-check-attempts))]
[(_ name property attempts)
(syntax/loc stx (check-metafunction name property random-decisions attempts))]
[(_ name property decisions attempts)
(with-syntax ([m (metafunc #'name stx)])
(syntax/loc stx
(or (check-property-many
(parse-language (metafunc-proc-lang m))
(metafunc-proc-lhs-pats m)
(build-list (length (metafunc-proc-lhs-pats m))
(compose (curry format "clause #~s") add1))
property
decisions
attempts)
(void))))]))
(define (check-reduction-relation
relation property
#:decisions [decisions random-decisions]
#:attempts [attempts default-check-attempts])
(or (check-property-many
(parse-language (reduction-relation-lang relation))
(map rewrite-proc-lhs (reduction-relation-make-procs relation))
(map (λ (proc) (or (rewrite-proc-name proc) 'unnamed))
(reduction-relation-make-procs relation))
property
decisions
attempts)
(void)))
(define-signature decisions^
(next-variable-decision
next-number-decision
@ -693,7 +747,7 @@ To do a better job of not generating programs with free variables,
(define (random-decisions lang)
(define preferred-productions
(make-immutable-hasheq
(map (λ (nt) (cons (nt-name nt) (pick-from-list (nt-rhs nt))))
(map (λ (nt) (cons (nt-name nt) (list (pick-from-list (nt-rhs nt)))))
(append (compiled-lang-lang lang)
(compiled-lang-cclang lang)))))
(unit (import) (export decisions^)
@ -705,12 +759,13 @@ To do a better job of not generating programs with free variables,
(define (next-string-decision) pick-string)))
(provide pick-from-list pick-var min-prods decisions^ pick-sequence-length
is-nt? pick-char random-string pick-string check
pick-nt unique-chars pick-any sexp generate parse-pattern
is-nt? pick-char random-string pick-string check nt-by-name
pick-nt unique-chars pick-any sexp generate-term parse-pattern
class-reassignments reassign-classes unparse-pattern
(struct-out ellipsis) (struct-out mismatch) (struct-out class)
(struct-out binder) generate/decisions check-metafunction-contract
pick-number parse-language)
(struct-out binder) check-metafunction-contract
pick-number parse-language check-reduction-relation
preferred-production-threshold check-metafunction)
(provide/contract
[find-base-cases (-> compiled-lang? hash?)])

9
collects/redex/private/struct.ss
View File

@ -9,7 +9,7 @@
build-reduction-relation
reduction-relation?
empty-reduction-relation
make-rewrite-proc rewrite-proc? rewrite-proc-name
make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs
(struct-out rule-pict))
(define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds))
@ -20,13 +20,14 @@
;; we want to avoid doing it multiple times, so it is cached in a reduction-relation struct
(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name)
(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs)
(let ()
(define-values (type constructor predicate accessor mutator)
(make-struct-type 'rewrite-proc #f 2 0 #f '() #f 0))
(make-struct-type 'rewrite-proc #f 3 0 #f '() #f 0))
(values constructor
predicate
(make-struct-field-accessor accessor 1 'name))))
(make-struct-field-accessor accessor 1 'name)
(make-struct-field-accessor accessor 2 'lhs))))
;; lang : compiled-language
;; make-procs = (listof (compiled-lang -> proc))

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

@ -1,6 +1,9 @@
(module tl-test mzscheme
(require "../reduction-semantics.ss"
"test-util.ss")
"test-util.ss"
(only "matcher.ss" make-bindings make-bind)
scheme/match
"struct.ss")
(reset-count)
@ -537,6 +540,19 @@
(list '((2 3) 20)
'(6 (4 5))))
; shortcuts like this fail if compilation fails to preserve
; lexical context for side-conditions expressions.
(test (let ([x #t])
(apply-reduction-relation
(reduction-relation
grammar
(==> variable variable)
with
[(--> (a (side-condition number x)) b)
(==> a b)])
'(x 4)))
'(x))
(test (apply-reduction-relation/tag-with-names
(reduction-relation
grammar
@ -1099,4 +1115,48 @@
'x)
'(x1))
(let ([r (reduction-relation
grammar
(->1 1 2)
(->2 3 4)
(->4 5 6)
with
[(--> (side-condition (a number) (even? (term number))) b)
(->1 a b)]
[(--> (X
(number number)
(X_1 X_1)
(M_!_1 M_!_1)
(1 ..._1 1 ..._1)
(1 ..._!_1 1 ..._!_1))
b)
(->2 X b)]
[(--> (a 1) b)
(->3 a b)]
[(->3 (a 2) b)
(->4 a b)])])
; test that names are properly bound for side-conditions in shortcuts
(let* ([lhs (rewrite-proc-lhs (first (reduction-relation-make-procs r)))]
[proc (third lhs)]
[name (cadadr lhs)]
[bind (λ (n) (make-bindings (list (make-bind name n))))])
(test (and (proc (bind 4)) (not (proc (bind 3)))) #t))
; test binder renaming
(let ([sym-mtch? (λ (rx) (λ (s) (and (symbol? s) (regexp-match? rx (symbol->string s)))))])
(match (rewrite-proc-lhs (second (reduction-relation-make-procs r)))
[`(3
(,(and n1 (? (sym-mtch? #px"^number_\\d+$"))) ,n1)
(,(and n2 (? (sym-mtch? #px"^X_1\\d+$"))) ,n2)
(,(and m1 (? (sym-mtch? #px"^M_!_1\\d+$"))) ,m1)
(1 ,(and ...1 (? (sym-mtch? #px"^\\.\\.\\._1\\d+$"))) 1 ,...1)
(1 ,(and ...!1 (? (sym-mtch? #px"^\\.\\.\\._!_1\\d+$"))) 1 ,...!1))
#t]
[else #f]))
; test shortcut in terms of shortcut
(test (rewrite-proc-lhs (third (reduction-relation-make-procs r)))
'((5 2) 1)))
(print-tests-passed 'tl-test.ss))

14
collects/redex/redex.scrbl
View File

@ -450,6 +450,12 @@ recursively matches the corresponding list element. There
may be a single ellipsis in any list pattern; if one is
present, the pattern before the ellipses may match multiple
adjacent elements in the list value (possibly none).
This form is a lower-level form in Redex, and not really designed to
be used directly. If you want a @scheme[let]-like form that uses
Redex's full pattern matching facilities, see @scheme[term-match] and
@scheme[term-match/single].
}
@defform[(term-match language [#, @|ttpattern| expression] ...)]{
@ -460,6 +466,10 @@ function returns a list of the values of the expression
where the pattern matches. If one of the patterns matches
multiple times, the expression is evaluated multiple times,
once with the bindings in the pattern for each match.
When evaluating a @scheme[term-match] expression, the patterns are
compiled in an effort to speed up matching. Using the procedural
result multiple times to avoid compiling the patterns multiple times.
}
@defform[(term-match/single language [#, @|ttpattern| expression] ...)]{
@ -472,6 +482,10 @@ is signaled. If no patterns match, an error is signaled.
Raises an exception recognized by @scheme[exn:fail:redex?] if
no clauses match or if one of the clauses matches multiple ways.
When evaluating a @scheme[term-match/single] expression, the patterns
are compiled in an effort to speed up matching. Using the procedural
result multiple times to avoid compiling the patterns multiple times.
}
@defproc[(plug [context any?] [expression any?]) any]{

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "22dec2008")
#lang scheme/base (provide stamp) (define stamp "2jan2009")

12
collects/rnrs/arithmetic/fixnums-6.ss
View File

@ -62,16 +62,20 @@
(raise-type-error 'fxdiv-and-mod "fixnum" a))
(unless (fixnum? b)
(raise-type-error 'fxdiv-and-mod "fixnum" b))
(div-and-mod a b))
(define-fx div fxdiv (a b) nocheck)
(let-values ([(d m) (div-and-mod a b)])
(check d (implementation-restriction 'div-and-mod d))
(values d m)))
(define-fx div fxdiv (a b) check)
(define-fx mod fxmod (a b) nocheck)
(define (fxdiv0-and-mod0 a b)
(unless (fixnum? a)
(raise-type-error 'fxdiv0-and-mod0 "fixnum" a))
(unless (fixnum? b)
(raise-type-error 'fxdiv0-and-mod0 "fixnum" b))
(div0-and-mod0 a b))
(define-fx div0 fxdiv0 (a b) nocheck)
(let-values ([(d m) (div0-and-mod0 a b)])
(check d (implementation-restriction 'div0-and-mod0 d))
(values d m)))
(define-fx div0 fxdiv0 (a b) check)
(define-fx mod0 fxmod0 (a b) nocheck)
(define-syntax-rule (define-carry fx/carry (a b c) expr)

7
collects/scheme/gui/dynamic.ss
View File

@ -4,9 +4,10 @@
gui-dynamic-require)
(define (gui-available?)
(with-handlers ([exn:fail? (lambda (exn) #f)])
(eq? (dynamic-require 'mred/private/dynamic 'kernel-initialized)
'done)))
(and (zero? (variable-reference->phase (#%variable-reference)))
(with-handlers ([exn:fail? (lambda (exn) #f)])
(eq? (dynamic-require 'mred/private/dynamic 'kernel-initialized)
'done))))
(define-namespace-anchor anchor)

33
collects/scheme/list.ss
View File

@ -22,6 +22,9 @@
filter-map
partition
argmin
argmax
;; convenience
append-map
filter-not)
@ -278,3 +281,33 @@
(if (null? l)
(reverse result)
(loop (cdr l) (if (f (car l)) result (cons (car l) result))))))
;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X
(define (mk-min cmp name f xs)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
(raise-type-error name "procedure (arity 1)" f))
(unless (and (list? xs)
(pair? xs))
(raise-type-error name "non-empty list" xs))
(let ([init-min-var (f (car xs))])
(unless (real? init-min-var)
(raise-type-error name "procedure that returns real numbers" f))
(let loop ([min (car xs)]
[min-var init-min-var]
[xs (cdr xs)])
(cond
[(null? xs) min]
[else
(let ([new-min (f (car xs))])
(unless (real? new-min)
(raise-type-error name "procedure that returns real numbers" f))
(cond
[(cmp new-min min-var)
(loop (car xs) new-min (cdr xs))]
[else
(loop min min-var (cdr xs))]))]))))
(define (argmin f xs) (mk-min < 'argmin f xs))
(define (argmax f xs) (mk-min > 'argmax f xs))

176
collects/scheme/private/class-internal.ss
View File

@ -29,8 +29,8 @@
define-serializable-class define-serializable-class*
class?
mixin
interface interface?
object% object? externalizable<%> printable<%>
interface interface* interface?
object% object? externalizable<%> printable<%> equal<%>
object=?
new make-object instantiate
send send/apply send* class-field-accessor class-field-mutator with-method
@ -2008,7 +2008,7 @@
[method-names (append (reverse public-names) super-method-ids)]
[field-names (append public-field-names super-field-ids)]
[super-interfaces (cons (class-self-interface super) interfaces)]
[i (interface-make name super-interfaces #f method-names #f)]
[i (interface-make name super-interfaces #f method-names #f null)]
[methods (if no-method-changes?
(class-methods super)
(make-vector method-width))]
@ -2050,7 +2050,7 @@
;; --- Make the new object struct ---
(let*-values ([(prim-object-make prim-object? struct:prim-object)
(if make-struct:prim
(make-struct:prim c prop:object preparer dispatcher)
(make-struct:prim c prop:object preparer dispatcher (get-properties interfaces))
(values #f #f #f))]
[(struct:object object-make object? object-field-ref object-field-set!)
(if make-struct:prim
@ -2058,21 +2058,14 @@
(values struct:prim-object prim-object-make prim-object? #f #f)
;; Normal struct creation:
(make-struct-type obj-name
(class-struct:object super)
(add-properties (class-struct:object super) interfaces)
0 ;; No init fields
;; Fields for new slots:
num-fields undefined
;; Map object property to class:
(append
(list (cons prop:object c))
(if (interface-extension? i printable<%>)
(list (cons prop:custom-write
(lambda (obj port write?)
(if write?
(send obj custom-write port)
(send obj custom-display port)))))
null)
(if deserialize-id
(if deserialize-id
(list
(cons prop:serializable
;; Serialization:
@ -2329,6 +2322,33 @@
(for-class name))))
syms)))
(define (get-properties intfs)
(if (ormap (lambda (i)
(pair? (interface-properties i)))
intfs)
(let ([ht (make-hash)])
;; Hash on gensym to avoid providing the same property multiple
;; times when it originated from a single interface.
(for-each (lambda (i)
(for-each (lambda (p)
(hash-set! ht (vector-ref p 0) p))
(interface-properties i)))
intfs)
(hash-map ht (lambda (k v) (cons (vector-ref v 1)
(vector-ref v 2)))))
;; No properties to add:
null))
(define (add-properties struct-type intfs)
(let ([props (get-properties intfs)])
(if (null? props)
struct-type
;; Create a new structure type to house the properties, so
;; that they can't see any fields directly via guards:
(let-values ([(struct: make- ? -ref -set!)
(make-struct-type 'props struct-type 0 0 #f props #f)])
struct:))))
(define-values (prop:object object? object-ref) (make-struct-type-property 'object))
;;--------------------------------------------------------------------
@ -2337,10 +2357,10 @@
;; >> Simplistic implementation for now <<
(define-syntax _interface
(lambda (stx)
(syntax-case stx ()
[(_ (interface-expr ...) var ...)
(define-for-syntax do-interface
(lambda (stx m-stx)
(syntax-case m-stx ()
[((interface-expr ...) ([prop prop-val] ...) var ...)
(let ([vars (syntax->list (syntax (var ...)))]
[name (syntax-local-infer-name stx)])
(for-each
@ -2364,7 +2384,33 @@
(compose-interface
'name
(list interface-expr ...)
`(var ...)))))])))
`(var ...)
(list prop ...)
(list prop-val ...)))))])))
(define-syntax (_interface stx)
(syntax-case stx ()
[(_ (interface-expr ...) var ...)
(do-interface stx #'((interface-expr ...) () var ...))]))
(define-syntax (interface* stx)
(syntax-case stx ()
[(_ (interface-expr ...) ([prop prop-val] ...) var ...)
(do-interface stx #'((interface-expr ...) ([prop prop-val] ...) var ...))]
[(_ (interface-expr ...) (prop+val ...) var ...)
(for-each (lambda (p+v)
(syntax-case p+v ()
[(p v) (void)]
[_ (raise-syntax-error #f
"expected `[<prop-expr> <val-expr>]'"
stx
p+v)]))
(syntax->list #'(prop+val ...)))]
[(_ (interface-expr ...) prop+vals . _)
(raise-syntax-error #f
"expected `([<prop-expr> <val-expr>] ...)'"
stx
#'prop+vals)]))
(define-struct interface
(name ; symbol
@ -2373,18 +2419,27 @@
#:mutable]
public-ids ; (listof symbol) (in any order?!?)
[class ; (union #f class) -- means that anything implementing
#:mutable]) ; this interface must be derived from this class
#:mutable] ; this interface must be derived from this class
properties) ; (listof (vector gensym prop val))
#:inspector insp)
(define (compose-interface name supers vars)
(define (compose-interface name supers vars props vals)
(for-each
(lambda (intf)
(unless (interface? intf)
(obj-error 'interface
"superinterface expression returned a non-interface: ~a~a"
"superinterface expression returned a non-interface: ~e~a"
intf
(for-intf name))))
supers)
(for-each
(lambda (p)
(unless (struct-type-property? p)
(obj-error 'interface
"property expression returned a non-property: ~e~a"
p
(for-intf name))))
props)
(let ([ht (make-hasheq)])
(for-each
(lambda (var)
@ -2405,24 +2460,38 @@
"")))))
(interface-public-ids super)))
supers)
;; Check for [conflicting] implementation requirements
(let ([class (get-implement-requirement supers 'interface (for-intf name))]
[interface-make (if name
(make-naming-constructor
struct:interface
(string->symbol (format "interface:~a" name)))
make-interface)])
;; Add supervars to table:
(for-each
(lambda (super)
(for-each
(lambda (var) (hash-set! ht var #t))
(interface-public-ids super)))
supers)
;; Done
(let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class)])
(setup-all-implemented! i)
i))))
;; Merge properties:
(let ([prop-ht (make-hash)])
;; Hash on gensym to avoid providing the same property multiple
;; times when it originated from a single interface.
(for-each (lambda (i)
(for-each (lambda (p)
(hash-set! prop-ht (vector-ref p 0) p))
(interface-properties i)))
supers)
(for-each (lambda (p v)
(let ([g (gensym)])
(hash-set! prop-ht g (vector g p v))))
props vals)
;; Check for [conflicting] implementation requirements
(let ([class (get-implement-requirement supers 'interface (for-intf name))]
[interface-make (if name
(make-naming-constructor
struct:interface
(string->symbol (format "interface:~a" name)))
make-interface)])
;; Add supervars to table:
(for-each
(lambda (super)
(for-each
(lambda (var) (hash-set! ht var #t))
(interface-public-ids super)))
supers)
;; Done
(let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class
(hash-map prop-ht (lambda (k v) v)))])
(setup-all-implemented! i)
i)))))
;; setup-all-implemented! : interface -> void
;; Creates the hash table for all implemented interfaces
@ -2466,7 +2535,7 @@
make-))
(define object<%> ((make-naming-constructor struct:interface 'interface:object%)
'object% null #f null #f))
'object% null #f null #f null))
(setup-all-implemented! object<%>)
(define object% ((make-naming-constructor struct:class 'class:object%)
'object%
@ -3362,6 +3431,7 @@
prim-init ; primitive initializer: takes obj and list of name-arg pairs
name ; symbol
super ; superclass
intfs ; interfaces
init-arg-names ; #f or list of syms and sym--value lists
override-names ; overridden method names
new-names ; new (public) method names
@ -3369,7 +3439,7 @@
new-methods) ; list of methods
; The `make-struct:prim' function takes prop:object, a
; class, a preparer, and a dispatcher function, and produces:
; class, a preparer, a dispatcher function, and a property assoc list, and produces:
; * a struct constructor (must have prop:object)
; * a struct predicate
; * a struct type for derived classes (mustn't have prop:object)
@ -3384,7 +3454,7 @@
(compose-class name
(or super object%)
null
intfs
#f
#f
#f
@ -3726,7 +3796,23 @@
(_interface () externalize internalize))
(define printable<%>
(_interface () custom-write custom-display))
(interface* ()
([prop:custom-write (lambda (obj port write?)
(if write?
(send obj custom-write port)
(send obj custom-display port)))])
custom-write custom-display))
(define equal<%>
(interface* ()
([prop:equal+hash (list
(lambda (obj obj2 base-equal?)
(send obj equal-to? obj2 base-equal?))
(lambda (obj base-hash-code)
(send obj equal-hash-code-of base-hash-code))
(lambda (obj base-hash2-code)
(send obj equal-secondary-hash-code-of base-hash2-code)))])
equal-to? equal-hash-code-of equal-secondary-hash-code-of))
;; Providing traced versions:
(provide class-traced
@ -3768,8 +3854,8 @@
define-serializable-class define-serializable-class*
class?
mixin
(rename-out [_interface interface]) interface?
object% object? object=? externalizable<%> printable<%>
(rename-out [_interface interface]) interface* interface?
object% object? object=? externalizable<%> printable<%> equal<%>
new make-object instantiate
get-field field-bound? field-names
send send/apply send* class-field-accessor class-field-mutator with-method

82
collects/scheme/private/more-scheme.ss
View File

@ -210,6 +210,35 @@
(define handler-prompt-key (make-continuation-prompt-tag))
(define (call-handled-body bpz handle-proc body-thunk)
;; Disable breaks here, so that when the exception handler jumps
;; to run a handler, breaks are disabled for the handler
(with-continuation-mark
break-enabled-key
false-thread-cell
(call-with-continuation-prompt
(lambda (bpz body-thunk)
;; Restore the captured break parameterization for
;; evaluating the `with-handlers' body. In this
;; special case, no check for breaks is needed,
;; because bpz is quickly restored past call/ec.
;; Thus, `with-handlers' can evaluate its body in
;; tail position.
(with-continuation-mark
break-enabled-key
bpz
(with-continuation-mark
exception-handler-key
(lambda (e)
;; Deliver the exception to the escape handler:
(abort-current-continuation
handler-prompt-key
e))
(body-thunk))))
handler-prompt-key
handle-proc
bpz body-thunk)))
(define-syntaxes (with-handlers with-handlers*)
(let ([wh
(lambda (disable-break?)
@ -222,44 +251,21 @@
[(handler-name ...) (generate-temporaries (map (lambda (x) 'with-handlers-handler)
(syntax->list #'(handler ...))))])
(quasisyntax/loc stx
(let ([pred-name pred] ...
[handler-name handler] ...)
;; Capture current break parameterization, so we can use it to
;; evaluate the body
(let ([bpz (continuation-mark-set-first #f break-enabled-key)])
;; Disable breaks here, so that when the exception handler jumps
;; to run a handler, breaks are disabled for the handler
(with-continuation-mark
break-enabled-key
false-thread-cell
(call-with-continuation-prompt
(lambda ()
;; Restore the captured break parameterization for
;; evaluating the `with-handlers' body. In this
;; special case, no check for breaks is needed,
;; because bpz is quickly restored past call/ec.
;; Thus, `with-handlers' can evaluate its body in
;; tail position.
(with-continuation-mark
break-enabled-key
bpz
(with-continuation-mark
exception-handler-key
(lambda (e)
;; Deliver a thunk to the escape handler:
(abort-current-continuation
handler-prompt-key
(lambda ()
(#,(if disable-break?
#'select-handler/no-breaks
#'select-handler/breaks-as-is)
e bpz
(list (cons pred-name handler-name) ...)))))
(let ()
expr1 expr ...))))
handler-prompt-key
;; On escape, apply the handler thunk
(lambda (thunk) (thunk))))))))])))])
(let-values ([(pred-name) pred] ...
[(handler-name) handler] ...)
;; Capture current break parameterization, so we can use it to
;; evaluate the body
(let ([bpz (continuation-mark-set-first #f break-enabled-key)])
(call-handled-body
bpz
(lambda (e)
(#,(if disable-break?
#'select-handler/no-breaks
#'select-handler/breaks-as-is)
e bpz
(list (cons pred-name handler-name) ...)))
(lambda ()
expr1 expr ...))))))])))])
(values (wh #t) (wh #f))))
(define (call-with-exception-handler exnh thunk)

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

@ -486,29 +486,33 @@
(define-syntax defstruct
(syntax-rules ()
[(_ name fields #:mutable #:inspector #f desc ...)
(**defstruct name fields #f #t desc ...)]
(**defstruct name fields #f #t #f desc ...)]
[(_ name fields #:mutable #:transparent desc ...)
(**defstruct name fields #f #t desc ...)]
(**defstruct name fields #f #t #f desc ...)]
[(_ name fields #:mutable #:prefab desc ...)
(**defstruct name fields #f #t #t desc ...)]
[(_ name fields #:mutable desc ...)
(**defstruct name fields #f #f desc ...)]
(**defstruct name fields #f #f #f desc ...)]
[(_ name fields #:inspector #f desc ...)
(**defstruct name fields #t #t desc ...)]
(**defstruct name fields #t #t #f desc ...)]
[(_ name fields #:transparent desc ...)
(**defstruct name fields #t #t desc ...)]
(**defstruct name fields #t #t #f desc ...)]
[(_ name fields #:prefab desc ...)
(**defstruct name fields #t #t #t desc ...)]
[(_ name fields desc ...)
(**defstruct name fields #t #f desc ...)]))
(**defstruct name fields #t #f #f desc ...)]))
(define-syntax-rule (**defstruct name ([field field-contract] ...) immutable?
transparent? desc ...)
transparent? prefab? desc ...)
(with-togetherable-scheme-variables
()
()
(*defstruct (quote-syntax/loc name) 'name
'([field field-contract] ...)
(list (lambda () (schemeblock0 field-contract)) ...)
immutable? transparent? (lambda () (list desc ...)))))
immutable? transparent? prefab? (lambda () (list desc ...)))))
(define (*defstruct stx-id name fields field-contracts immutable? transparent?
(define (*defstruct stx-id name fields field-contracts immutable? transparent? prefab?
content-thunk)
(define (field-name f) ((if (pair? (car f)) caar car) f))
(define (field-view f)
@ -634,7 +638,9 @@
(list flow-spacer flow-spacer
(to-flow (make-element
#f
(list (to-element '#:transparent)
(list (if prefab?
(to-element '#:prefab)
(to-element '#:transparent))
(schemeparenfont ")"))))
'cont
'cont))]
@ -652,7 +658,9 @@
(list flow-spacer flow-spacer
(to-flow (make-element
#f
(list (to-element '#:transparent)
(list (if prefab?
(to-element '#:prefab)
(to-element '#:transparent))
(schemeparenfont ")"))))
'cont
'cont))]

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

@ -282,7 +282,9 @@ PLT Scheme's C API.}
Similar to @scheme[_pointer], except that when an @scheme[_fpointer]
is extracted from a pointer produced by @scheme[ffi-obj-ref], then a
level of indirection is skipped. A level of indirection is similarly
skipped when extracting a pointer via @scheme[get-ffi-obj].
skipped when extracting a pointer via @scheme[get-ffi-obj]. Also
unlike @scheme[_pointer], @scheme[_fpointer] does not convert
@scheme[#f] to @cpp{NULL}.
A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer],
and normally @scheme[_cprocedure] should be used instead of
@ -439,9 +441,11 @@ For example,
specifies a function that receives an integer and a string, but the
foreign function receives the string first.}
@defproc[(function-ptr [ptr cpointer?] [fun-type ctype?]) cpointer?]{
@defproc[(function-ptr [ptr-or-proc (or cpointer? procedure?)]
[fun-type ctype?])
cpointer?]{
Casts @scheme[ptr] to a function pointer of type @scheme[fun-type].}
Casts @scheme[ptr-or-proc] to a function pointer of type @scheme[fun-type].}
@; ----------------------------------------------------------------------

48
collects/scribblings/gui/image-snip-class.scrbl
View File

@ -1,7 +1,7 @@
#lang scribble/doc
@(require "common.ss")
@defclass/title[image-snip% snip% ()]{
@defclass/title[image-snip% snip% (equal<%>)]{
An @scheme[image-snip%] is a snip that can display bitmap images
(usually loaded from a file). When the image file cannot be found, a
@ -24,6 +24,38 @@ Creates an image snip, loading the image @scheme[filename] if
}
@defmethod[(equal-hash-code [hash-code (any/c . -> . exact-integer?)])
exact-integer?]{
Returns an integer that can be used as a @scheme[equal?]-based hash
code for @this-obj[] (using the same notion of @scheme[equal?] as
@method[image-snip% other-equal-to?]).
See also @scheme[equal<%>].}
@defmethod[(equal-secondary-hash-code [hash-code (any/c . -> . exact-integer?)])
exact-integer?]{
Returns an integer that can be used as a @scheme[equal?]-based
secondary hash code for @this-obj[] (using the same notion of
@scheme[equal?] as @method[image-snip% other-equal-to?]).
See also @scheme[equal<%>].}
@defmethod[(equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)])
boolean?]{
Calls the @method[image-snip% other-equal-to?] method of @scheme[snip]
(to simulate multi-method dispatch) in case @scheme[snip] provides a
more specific equivalence comparison.
See also @scheme[equal<%>].}
@defmethod[(get-bitmap)
(or/c (is-a?/c bitmap%) false/c)]{
@ -105,6 +137,20 @@ If @scheme[inline?] is not @scheme[#f], the image data will be saved
}
@defmethod[(other-equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)])
boolean?]{
Returns @scheme[#t] if @this-obj[] and @scheme[snip] both have bitmaps
and the bitmaps are the same dimensions. If either has a mask bitmap
with the same dimensions as the main bitmap, then the masks must be
the same (or if only one mask is present, it must correspond to a
solid mask).
The given @scheme[equal?] function (for recursive comparisons) is not
used.}
@defmethod[#:mode override
(resize [w (and/c real? (not/c negative?))]
[h (and/c real? (not/c negative?))])

2
collects/scribblings/guide/case.scrbl
View File

@ -4,7 +4,7 @@
"guide-utils.ss"
(for-label scheme/match))
@title{Simple Dispatch: @scheme[case]}
@title[#:tag "case"]{Simple Dispatch: @scheme[case]}
The @scheme[case] form dispatches to a clause by matching the result
of an expression to the values for the clause:

1
collects/scribblings/guide/forms.scrbl
View File

@ -90,3 +90,4 @@ form, a @scheme[_thing] is either an identifier or a keyword.
@include-section["quote.scrbl"]
@include-section["qq.scrbl"]
@include-section["case.scrbl"]
@include-section["parameterize.scrbl"]

67
collects/scribblings/guide/parameterize.scrbl Normal file
View File

@ -0,0 +1,67 @@
#lang scribble/doc
@(require scribble/manual
scribble/eval
"guide-utils.ss")
@title[#:tag "parameterize"]{Dynamic Binding: @scheme[parameterize]}
The @scheme[parameterize] form supports a kind of dynamic binding that
is useful for adjusting defaults or passing extra arguments through
layers of function calls. The settings that are adjusted by a
@scheme[parameterize] form are called @deftech{parameters}.
@margin-note{The term ``parameter'' is sometimes used to refer to the
arguments of a function, but ``parameter'' in PLT Scheme
has the more specific meaning described here.}
@specform[(parameterize ([parameter-expr value-expr] ...)
body ...+)]
The result of a @scheme[parameterize] form is the result of the last
@scheme[_body] expression. While the @scheme[_body] expressions are
evaluated, the parameter produced by each @scheme[_parameter-expr] is
set to the result of the corresponding @scheme[_value-expr].
Many parameters are built in. For example, the
@scheme[error-print-width] parameter controls how many characters of a
value are printed in an error message (in case the printed form of the
value is very large):
@interaction[
(parameterize ([error-print-width 10])
(car (expt 10 1024)))
(parameterize ([error-print-width 5])
(car (expt 10 1024)))
]
The @scheme[error-print-width] parameter acts like a kind of default
argument to the function that formats error messages. This
parameter-based argument can be configured far from the actual call to
the error-formatting function, which in this case is called deep
within the implementation of @scheme[car].
The @scheme[parameterize] form adjusts the value of a parameter only
while evaluating its body expressions. After the body produces a
value, the parameter reverts to its previous value. If control escapes
from the body due to an exception, as in the above example, then the
parameter value is restored in that case, too. Finally, parameter
values are thread-specific, so that multiple threads do not interfere
with each others' settings.
Use @scheme[make-parameter] to create a new parameter that works with
@scheme[parameterize]. The argument to @scheme[make-parameter] is the
value of the parameter when it is not otherwise set by
@scheme[parameterize]. To access the current value of the parameter,
call it like a function.
@interaction[
(define favorite-flavor (make-parameter 'chocolate))
(favorite-flavor)
(define (scoop)
`(scoop of ,(favorite-flavor)))
(define (ice-cream n)
(list (scoop) (scoop) (scoop)))
(parameterize ([favorite-flavor 'strawberry])
(ice-cream 3))
(ice-cream 3)
]

18
collects/scribblings/more/more.scrbl
View File

@ -4,6 +4,7 @@
scribble/eval
"../quick/keep.ss"
(for-label scheme
scheme/enter
readline
net/url
xml
@ -422,7 +423,7 @@ To parse the incoming URL and to more easily format HTML output, we'll
require two extra libraries:
@schemeblock[
(require net/url xml)
(require xml net/url)
]
The @schememodname[xml] library gives us @scheme[xexpr->string], which
@ -582,15 +583,12 @@ connection. Inside @scheme[accept-and-handle], after the definition of
@whole-prog["7"]
We're assuming that 50MB should be plenty for any servlet. Due to the
way that memory accounting is defined, @scheme[cust] might also be
charged for the core server implementation and all of the libraries
loaded on start-up, so the limit cannot be too small. Also,
garbage-collector overhead means that the actual memory use of the
system can be some small multiple of 50 MB. An important guarantee,
however, is that different connections will not be charged for each
other's memory use, so one misbehaving connection will not interfere
with a different one.
We're assuming that 50MB should be plenty for any
servlet. Garbage-collector overhead means that the actual memory use
of the system can be some small multiple of 50 MB. An important
guarantee, however, is that different connections will not be charged
for each other's memory use, so one misbehaving connection will not
interfere with a different one.
So, with the new line above, and assuming that you have a couple of
hundred megabytes available for the @exec{mzscheme} process to use,

19
collects/scribblings/mzc/decompile.scrbl
View File

@ -1,7 +1,9 @@
#lang scribble/doc
@(require scribble/manual
"common.ss"
(for-label scheme/base))
(for-label scheme/base
compiler/decompile
(only-in compiler/zo-parse compilation-top?)))
@title[#:tag "decompile"]{Decompiling Bytecode}
@ -84,3 +86,18 @@ Many forms in the decompiled code, such as @scheme[module],
syntax objects to a readable form.}
]
@; ------------------------------------------------------------
@section{Scheme API for Decompiling}
@defmodule[compiler/decompile]
@defproc[(decompile [top compilation-top?]) any/c]{
Consumes the result of parsing bytecode and returns an S-expression
(as described above) that represents the compiled code.}
@; ------------------------------------------------------------
@include-section["zo-parse.scrbl"]

464
collects/scribblings/mzc/zo-parse.scrbl Normal file
View File

@ -0,0 +1,464 @@
#lang scribble/doc
@(require scribble/manual
(for-label scheme/base
compiler/zo-parse))
@(define-syntax-rule (defstruct+ id fields . rest)
(defstruct id fields #:transparent . rest))
@title{Scheme API for Parsing Bytecode}
@defmodule[compiler/zo-parse]
@defproc[(zo-parse [in input-port?]) compilation-top?]{
Parses a port (typically the result of opening a @filepath{.zo} file)
containing byte. The parsed bytecode is returned in a
@scheme[compilation-top] structure.
Beware that the structure types used to represent the bytecode are
subject to frequent changes across PLT Scheme versons.}
@; --------------------------------------------------
@section{Prefix}
@defstruct+[compilation-top ([max-let-depth exact-nonnegative-integer?]
[prefix prefix?]
[code (or/c form? indirect? any/c)])]{
Wraps compiled code. The @scheme[max-let-depth] field indicates the
maximum stack depth that @scheme[code] creates (not counting the
@scheme[prefix] array). The @scheme[prefix] field describes top-level
variables, module-level variables, and quoted syntax-objects accessed
by @scheme[code]. The @scheme[code] field contains executable code; it
is normally a @scheme[form], but a literal value is represented as
itself.}
@defstruct+[prefix ([num-lifts exact-nonnegative-integer?]
[toplevels (listof (or/c #f symbol? global-bucket? module-variable?))]
[stxs (listof stx?)])]{
Represents a ``prefix'' that is pushed onto the stack to initiate
evaluation. The prefix is an array, where buckets holding the values
for @scheme[toplevels] are first, then a bucket for another array if
@scheme[stxs] is non-empty, then @scheme[num-lifts] extra buckets for
lifted local procedures.
In @scheme[toplevels], each element is one of the following:
@itemize[
@item{a @scheme[#f], which indicates a dummy variable that is used to
access the enclosing module/namespace at run time;}
@item{a symbol, which is a reference to a variable defined in the
enclosing module;}
@item{a @scheme[global-bucket], which is a top-level variable
(appears only outside of modules); or}
@item{a @scheme[module-variable], which indicates a variable imported
from another module.}
]
The variable buckets and syntax objects that are recorded in a prefix
are accessed by @scheme[toplevel] and @scheme[topsyntax] expression
forms.}
@defstruct+[global-bucket ([name symbol?])]{
Represents a top-level variable, and used only in a @scheme[prefix].}
@defstruct+[module-variable ([modidx module-path-index?]
[sym symbol?]
[pos exact-integer?]
[phase (or/c 0 1)])]{
Represents a top-level variable, and used only in a @scheme[prefix].
The @scheme[pos] may record the variable's offset within its module,
or it can be @scheme[-1] if the variable is always located by name.
The @scheme[phase] indicates the phase level of the definition within
its module.}
@defstruct+[stx ([encoded wrapped?])]{
Wraps a syntax object in a @scheme[prefix].}
@; --------------------------------------------------
@section{Forms}
@defstruct+[form ()]{
A supertype for all forms that can appear in compiled code (including
@scheme[expr]s), except for literals that are represented as
themselves and @scheme[indirect] structures to create cycles.}
@defstruct+[(def-values form) ([ids (listof toplevel?)]
[rhs (or/c expr? seq? indirect? any/c)])]{
Represents a @scheme[define-values] form. Each element of @scheme[ids]
will reference via the prefix either a top-level variable or a local
module variable.
After @scheme[rhs] is evaluated, the stack is restored to its depth
from before evaluating @scheme[rhs].}
@deftogether[(
@defstruct+[(def-syntaxes form) ([ids (listof toplevel?)]
[rhs (or/c expr? seq? indirect? any/c)]
[prefix prefix?]
[max-let-depth nonnegative-exact-integer?])]
@defstruct+[(def-for-syntax form) ([ids (listof toplevel?)]
[rhs (or/c expr? seq? indirect? any/c)]
[prefix prefix?]
[max-let-depth nonnegative-exact-integer?])]
)]{
Represents a @scheme[define-syntaxes] or
@scheme[define-values-for-syntax] form. The @scheme[rhs] expression
has its own @scheme[prefix], which is pushed before evaluating
@scheme[rhs]; the stack is restored after obtaining the result
values. The @scheme[max-let-depth] field indicates the maximum size of
the stack that will be created by @scheme[rhs] (not counting
@scheme[prefix]).}
@defstruct+[(req form) ([reqs (listof module-path?)]
[dummy toplevel?])]{
Represents a top-level @scheme[require] form (but not one in a
@scheme[module] form). The @scheme[dummy] variable is used to access
to the top-level namespace.}
@defstruct+[(mod form) ([name symbol?]
[self-modidx module-path-index?]
[prefix prefix?]
[provides (listof symbol?)]
[requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))]
[body (listof (or/c form? indirect? any/c))]
[syntax-body (listof (or/c def-syntaxes? def-for-syntax?))]
[max-let-depth exact-nonnegative-integer?])]{
Represents a @scheme[module] declaration. The @scheme[body] forms use
@scheme[prefix], rather than any prefix in place for the module
declaration itself (and each @scheme[syntax-body] has its own
prefix). The @scheme[body] field contains the module's run-time code,
and @scheme[syntax-body] contains the module's compile-time code. The
@scheme[max-let-depth] field indicates the maximum stack depth created
by @scheme[body] forms (not counting the @scheme[prefix] array).
After each form in @scheme[body] is evaluated, the stack is restored
to its depth from before evaluating the form.}
@defstruct+[(seq form) ([forms (listof (or/c form? indirect? any/c))])]{
Represents a @scheme[begin] form, either as an expression or at the
top level (though the latter is more commonly a @scheme[splice] form).
When a @scheme[seq] appears in an expression position, its
@scheme[forms] are expressions.
After each form in @scheme[forms] is evaluated, the stack is restored
to its depth from before evaluating the form.}
@defstruct+[(splice form) ([forms (listof (or/c form? indirect? any/c))])]{
Represents a top-level @scheme[begin] form where each evaluation is
wrapped with a continuation prompt.
After each form in @scheme[forms] is evaluated, the stack is restored
to its depth from before evaluating the form.}
@; --------------------------------------------------
@section{Expressions}
@defstruct+[(expr form) ()]{
A supertype for all expression forms that can appear in compiled code,
except for literals that are represented as themselves,
@scheme[indirect] structures to create cycles, and some @scheme[seq]
structures (which can appear as an expression as long as it contains
only other things that can be expressions).}
@defstruct+[(lam expr) ([name (or/c symbol? vector?)]
[flags exact-integer?]
[num-params exact-nonnegative-integer?]
[rest? boolean?]
[closure-map (vectorof exact-nonnegative-integer?)]
[max-let-depth exact-nonnegative-integer?]
[body (or/c expr? seq? indirect? any/c)])]{
Represents a @scheme[lambda] form. The @scheme[name] field is a name
for debugging purposes. The @scheme[num-params] field indicates the
number of arguments accepted by the procedure, not counting a rest
argument; the @scheme[rest?] field indicates whether extra arguments
are accepted and collected into a ``rest'' variable. The
@scheme[closure-map] field is a vector of stack positions that are
captured when evaluating the @scheme[lambda] form to create a closure.
When the function is called, the rest-argument list (if any) is pushed
onto the stack, then the normal arguments in reverse order, then the
closure-captured values in reverse order. Thus, when @scheme[body] is
run, the first value on the stack is the first value captured by the
@scheme[closure-map] array, and so on.
The @scheme[max-let-depth] field indicates the maximum stack depth
created by @scheme[body] (not including arguments and closure-captured
values pushed onto the stack). The @scheme[body] field is the
expression for the closure's body.}
@defstruct+[(closure expr) ([code lam?] [gen-id symbol?])]{
A @scheme[lambda] form with an empty closure, which is a procedure
constant. The procedure constant can appear multiple times in the
graph of expressions for bytecode, and the @scheme[code] field can
refer back to the same @scheme[closure] through an @scheme[indirect]
for a recursive constant procedure; the @scheme[gen-id] is different
for each such constant.}
@defstruct[indirect ([v closure?]) #:mutable #:prefab]{
An indirection used in expression positions to form cycles.}
@defstruct+[(case-lam expr) ([name (or/c symbol? vector?)]
[clauses (listof lam?)])]{
Represents a @scheme[case-lambda] form as a combination of
@scheme[lambda] forms that are tried (in order) based on the number of
arguments given.}
@defstruct+[(let-one expr) ([rhs (or/c expr? seq? indirect? any/c)]
[body (or/c expr? seq? indirect? any/c)])]{
Pushes an uninitialized slot onto the stack, evaluates @scheme[rhs]
and puts its value into the slot, and then runs @scheme[body].
After @scheme[rhs] is evaluated, the stack is restored to its depth
from before evaluating @scheme[rhs]. Note that the new slot is created
before evaluating @scheme[rhs].}
@defstruct+[(let-void expr) ([count nonnegative-exact-integer?]
[boxes? boolean?]
[body (or/c expr? seq? indirect? any/c)])]{
Pushes @scheme[count] uninitialized slots onto the stack and then runs
@scheme[body]. If @scheme[boxes?] is @scheme[#t], then the slots are
filled with boxes that contain @|undefined-const|.}
@defstruct+[(install-value expr) ([count nonnegative-exact-integer?]
[pos nonnegative-exact-integer?]
[boxes? boolean?]
[rhs (or/c expr? seq? indirect? any/c)]
[body (or/c expr? seq? indirect? any/c)])]{
Runs @scheme[rhs] to obtain @scheme[count] results, and installs them
into existing slots on the stack in order, skipping the first
@scheme[pos] stack positions. If @scheme[boxes?] is @scheme[#t], then
the values are put into existing boxes in the stack slots.
After @scheme[rhs] is evaluated, the stack is restored to its depth
from before evaluating @scheme[rhs].}
@defstruct+[(let-rec expr) ([procs (listof lam?)]
[body (or/c expr? seq? indirect? any/c)])]{
Represents a @scheme[letrec] form with @scheme[lambda] bindings. It
allocates a closure shell for each @scheme[lambda] form in
@scheme[procs], pushes them onto the stack in reverse order, fills out
each shell's closure using the created shells, and then evaluates
@scheme[body].}
@defstruct+[(boxenv expr) ([pos nonnegative-exact-integer?]
[body (or/c expr? seq? indirect? any/c)])]{
Skips @scheme[pos] elements of the stack, setting the slot afterward
to a new box containing the slot's old value, and then runs
@scheme[body]. This form appears when a @scheme[lambda] argument is
mutated using @scheme[set!] within its body; calling the function
initially pushes the value directly on the stack, and this form boxes
the value so that it can be mutated later.}
@defstruct+[(localref expr) ([unbox? boolean?]
[pos nonnegative-exact-integer?]
[clear? boolean?])]{
Represents a local-variable reference; it accesses the value in the
stack slot after the first @scheme[pos] slots. If @scheme[unbox?] is
@scheme[#t], the stack slot contains a box, and a value is extracted
from the box. If @scheme[clear?] is @scheme[#t], then after the value
is obtained, the stack slot is cleared (to avoid retaining a reference
that can prevent reclamation of the value as garbage).}
@defstruct+[(toplevel expr) ([depth nonnegative-exact-integer?]
[pos nonnegative-exact-integer?]
[const? boolean?]
[ready? boolean?])]{
Represents a reference to a top-level or imported variable via the
@scheme[prefix] array. The @scheme[depth] field indicates the number
of stack slots to skip to reach the prefix array, and @scheme[pos] is
the offset into the array.
If @scheme[const?] is @scheme[#t], then the variable definitely will
be defined, and its value stays constant. If @scheme[ready?] is
@scheme[#t], then the variable definitely will be defined (but its
value might change in the future). If @scheme[const?] and
@scheme[ready?] are both @scheme[#f], then a check is needed to
determine whether the variable is defined.}
@defstruct+[(topsyntax expr) ([depth nonnegative-exact-integer?]
[pos nonnegative-exact-integer?]
[midpt nonnegative-exact-integer?])]{
Represents a reference to a quoted syntax object via the
@scheme[prefix] array. The @scheme[depth] field indicates the number
of stack slots to skip to reach the prefix array, and @scheme[pos] is
the offset into the array. The @scheme[midpt] value is used internally
for lazy calculation of syntax information.}
@defstruct+[(application expr) ([rator (or/c expr? seq? indirect? any/c)]
[rands (listof (or/c expr? seq? indirect? any/c))])]{
Represents a function call. The @scheme[rator] field is the expression
for the function, and @scheme[rands] are the argument
expressions. Before any of the expressions are evaluated,
@scheme[(length rands)] uninitialized stack slots are created (to be
used as temporary space).}
@defstruct+[(branch expr) ([test (or/c expr? seq? indirect? any/c)]
[then (or/c expr? seq? indirect? any/c)]
[else (or/c expr? seq? indirect? any/c)])]{
Represents an @scheme[if] form.
After @scheme[test] is evaluated, the stack is restored to its depth
from before evaluating @scheme[test].}
@defstruct+[(with-cont-mark expr) ([key (or/c expr? seq? indirect? any/c)]
[val (or/c expr? seq? indirect? any/c)]
[body (or/c expr? seq? indirect? any/c)])]{
Represents a @scheme[with-continuation-mark] expression.
After each of @scheme[key] and @scheme[val] is evaluated, the stack is
restored to its depth from before evaluating @scheme[key] or
@scheme[val].}
@defstruct+[(beg0 expr) ([seq (listof (or/c expr? seq? indirect? any/c))])]{
Represents a @scheme[begin0] expression.
After each expression in @scheme[seq] is evaluated, the stack is
restored to its depth from before evaluating the expression.}
@defstruct+[(varref expr) ([toplevel toplevel?])]{
Represents a @scheme[#%variable-reference] form.}
@defstruct+[(assign expr) ([id toplevel?]
[rhs (or/c expr? seq? indirect? any/c)]
[undef-ok? boolean?])]{
Represents a @scheme[set!] expression that assigns to a top-level or
module-level variable. (Assignments to local variables are represented
by @scheme[install-value] expressions.)
After @scheme[rhs] is evaluated, the stack is restored to its depth
from before evaluating @scheme[rhs].}
@defstruct+[(apply-values expr) ([proc (or/c expr? seq? indirect? any/c)]
[args-expr (or/c expr? seq? indirect? any/c)])]{
Represents @scheme[(call-with-values (lambda () args-expr) proc)],
which is handled specially by the run-time system.}
@defstruct+[(primval expr) ([id symbol?])]{
Represents a direct reference to a variable imported from the run-time
kernel.}
@; --------------------------------------------------
@section{Syntax Objects}
@defstruct+[wrapped ([datum any/c]
[wraps (listof wrap?)]
[certs list?])]{
Represents a syntax object, where @scheme[wraps] contain the lexical
information and @scheme[certs] is certificate information. When the
@scheme[datum] part is itself compound, its pieces are wrapped, too.}
@defstruct+[wrap ()]{
A supertype for lexical-information elements.}
@defstruct+[(lexical-rename wrap) ([alist (listof (cons/c identifier? identifier?))])]{
A local-binding mapping from symbols to binding-set names.}
@defstruct+[(phase-shift wrap) ([amt exact-integer?]
[src module-path-index?]
[dest module-path-index?])]{
Shifts module bindings later in the wrap set.}
@defstruct+[(module-rename wrap) ([phase exact-integer?]
[kind (or/c 'marked 'normal)]
[set-id any/c]
[unmarshals (listof make-all-from-module?)]
[renames (listof module-binding?)]
[mark-renames any/c]
[plus-kern? boolean?])]{
Represents a set of module and import bindings.}
@defstruct+[all-from-module ([path module-path-index?]
[phase (or/c exact-integer? #f)]
[src-phase (or/c exact-integer? #f)]
[exceptions (listof symbol?)]
[prefix symbol?])]{
Represents a set of simple imports from one module within a
@scheme[module-rename].}
@defstruct+[module-binding ([path module-path-index?]
[mod-phase (or/c exact-integer? #f)]
[import-phase (or/c exact-integer? #f)]
[id symbol?]
[nominal-path module-path-index?]
[nominal-phase (or/c exact-integer? #f)]
[nominal-id (or/c exact-integer? #f)])]{
Represents a single identifier import (i.e., the general case) within
a @scheme[module-rename].}

68
collects/scribblings/reference/booleans.scrbl
View File

@ -14,13 +14,24 @@ See also: @scheme[and], @scheme[or], @scheme[andmap], @scheme[ormap].
@defproc[(boolean? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is @scheme[#t] or @scheme[#f],
@scheme[#f] otherwise.}
@scheme[#f] otherwise.
@examples[
(boolean? #f)
(boolean? #t)
(boolean? 'true)
]}
@defproc[(not [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is @scheme[#f], @scheme[#f] otherwise.
}
@examples[
(not #f)
(not #t)
(not 'we-have-no-bananas)
]}
@defproc[(equal? [v1 any/c] [v2 any/c]) boolean?]{
@ -33,7 +44,15 @@ strings, byte strings, numbers, pairs, mutable pairs, vectors, hash
tables, and inspectable structures. In the last five cases, equality
is recursively defined; if both @scheme[v1] and @scheme[v2] contain
reference cycles, they are equal when the infinite unfoldings of the
values would be equal. See also @scheme[prop:equal+hash].}
values would be equal. See also @scheme[prop:equal+hash].
@examples[
(equal? 'yes 'yes)
(equal? 'yes 'no)
(equal? (expt 2 100) (expt 2 100))
(equal? 2 2.0)
(equal? (make-string 3 #\z) (make-string 3 #\z))
]}
@defproc[(eqv? [v1 any/c] [v2 any/c]) boolean?]{
@ -41,14 +60,47 @@ values would be equal. See also @scheme[prop:equal+hash].}
Two values are @scheme[eqv?] if and only if they are @scheme[eq?],
unless otherwise specified for a particular datatype.
The number and character datatypes are the only ones for which
@scheme[eqv?] differs from @scheme[eq?].}
The @tech{number} and @tech{character} datatypes are the only ones for which
@scheme[eqv?] differs from @scheme[eq?].
@examples[
(eqv? 'yes 'yes)
(eqv? 'yes 'no)
(eqv? (expt 2 100) (expt 2 100))
(eqv? 2 2.0)
(eqv? (integer->char #x3BB) (integer->char #x3BB))
(eqv? (make-string 3 #\z) (make-string 3 #\z))
]}
@defproc[(eq? [v1 any/c] [v2 any/c]) boolean?]{
Return @scheme[#t] if @scheme[v1] and @scheme[v2] refer to the same
object, @scheme[#f] otherwise. See also @secref["model-eq"].}
object, @scheme[#f] otherwise. See also @secref["model-eq"].
@examples[
(eq? 'yes 'yes)
(eq? 'yes 'no)
(let ([v (mcons 1 2)]) (eq? v v))
(eq? (mcons 1 2) (mcons 1 2))
(eq? (make-string 3 #\z) (make-string 3 #\z))
]}
@defproc[(equal?/recur [v1 any/c] [v2 any/c] [recur-proc (any/c any/c -> any/c)]) boolean?]{
Like @scheme[equal?], but using @scheme[recur-proc] for recursive
comparisons (which means that reference cycles are not handled
automatically). Non-@scheme[#f] results from @scheme[recur-proc] are
converted to @scheme[#t] before being returned by
@scheme[equal?/recur].
@examples[
(equal?/recur 1 1 (lambda (a b) #f))
(equal?/recur '(1) '(1) (lambda (a b) #f))
(equal?/recur '#(1 1 1) '#(1 1.2 3/4)
(lambda (a b) (<= (abs (- a b)) 0.25)))
]}
@defproc[(immutable? [v any/c]) boolean?]{
@ -74,7 +126,9 @@ type. The property value must be a list of three procedures:
The third argument is an @scheme[equal?] predicate to use for
recursive equality checks; use the given predicate instead of
@scheme[equal?] to ensure that data cycles are handled
properly.
properly and to work with @scheme[equal?/recur] (but beware
that an arbitrary function can be provided to
@scheme[equal?/recur]).
The @scheme[_equal-proc] is called for a pair of structures
only when they are not @scheme[eq?], and only when they both

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

@ -75,9 +75,9 @@
@title[#:tag "mzlib:class" #:style 'toc]{Classes and Objects}
@note-lib[scheme/class #:use-sources (scheme/private/class-internal)]
@guideintro["classes"]{classes and objects}
@local-table-of-contents[]
@note-lib[scheme/class #:use-sources (scheme/private/class-internal)]
A @deftech{class} specifies
@ -152,6 +152,8 @@ Classes, objects, and interfaces are all values. However, a class or
interface is not an object (i.e., there are no ``meta-classes'' or
``meta-interfaces'').
@local-table-of-contents[]
@; ------------------------------------------------------------------------
@section[#:tag "createinterface"]{Creating Interfaces}
@ -184,6 +186,23 @@ is the most specific requirement from its superinterfaces. If the
superinterfaces specify inconsistent derivation requirements, the
@exnraise[exn:fail:object].}
@defform[(interface* (super-interface-expr ...)
([property-expr val-expr] ...)
id ...)]{
Like @scheme[interface], but also associates to the interface the
structure-type properties produced by the @scheme[property-expr]s with
the corresponding @scheme[val-expr]s.
Whenever the resulting interface (or a sub-interface derived from it)
is explicitly implemented by a class through the @scheme[class*] form,
each property is attached with its value to a structure type that
instantiated by instances of the class. Specifically, the property is
attached to a structure type with zero immediate fields, which is
extended to produce the internal structure type for instances of the
class (so that no information about fields is accessible to the
structure type property's guard, if any).}
@; ------------------------------------------------------------------------
@section[#:tag "createclass"]{Creating Classes}
@ -1456,6 +1475,60 @@ Returns a flat-contract that recognizes classes that
are subclasses of @scheme[class].}
@; ------------------------------------------------------------------------
@section[#:tag "objectequality"]{Object Equality and Hashing}
But default, objects that are instances of different classes or that
are instances of a non-transparent class are @scheme[equal?] only if
they are @scheme[eq?]. Like transparent structures, two objects that
are instances of the same transparent class (i.e., every superclass of
the class has @scheme[#f] as its inspector) are @scheme[equal?] when
their field values are @scheme[equal?].
To customize the way that a class instance is compared to other
instances by @scheme[equal?], implement the @scheme[equal<%>]
interface.
@definterface[equal<%> ()]{}
The @scheme[equal<%>] interface includes three methods, which are
analogous to the functions provided for a structure type with
@scheme[prop:equal+hash]:
@itemize[
@item{@scheme[equal-to?] --- Takes two arguments. The first argument
is an object that is an instance of the same class (or a subclass
that does not re-declare its implementation of @scheme[equal<%>])
and that is being compared to the target object. The second argument
is a @scheme[equal?]-like procedure of two arguments that should be
used for recursive equality testing. The result should be a true
value if the object and the first argument of the method are equal,
@scheme[#f] otherwise.}
@item{@scheme[equal-hash-code-of] --- Takes one argument, which is a
procedure of one argument that should be used for recursive hash-code
computation. The result should be an exact integer representing the
target object's hash code.}
@item{@scheme[equal-secondary-hash-code-of] --- Takes one argument,
which is a procedure of one argument that should be used for
recursive hash-code computation. The result should be an exact
integer representing the target object's secondary hash code.}
]
The @scheme[equal<%>] interface is unusual in that declaring the
implementation of the interface is different from inheriting the
interface. Two objects can be equal only if they are instances of
classes whose most specific ancestor to explicitly implement
@scheme[equal<%>] is the same ancestor.
See @scheme[prop:equal+hash] for more information on equality
comparisons and hash codes. The @scheme[equal<%>] interface is
implemented with @scheme[interface*] and @scheme[prop:equal+hash].
@; ------------------------------------------------------------------------
@section[#:tag "objectserialize"]{Object Serialization}
@ -1533,11 +1606,11 @@ Like @scheme[define-serializable-class*], but with not interface
expressions (analogous to @scheme[class]).}
@defthing[externalizable<%> interface?]{
@definterface[externalizable<%> ()]{}
The @scheme[externalizable<%>] interface includes only the
@scheme[externalize] and @scheme[internalize] methods. See
@scheme[define-serializable-class*] for more information.}
@scheme[define-serializable-class*] for more information.
@; ------------------------------------------------------------------------
@ -1556,8 +1629,11 @@ a single argument, which is the destination port to @scheme[write] or
Calls to the @scheme[custom-write] or @scheme[custom-display] are like
calls to a procedure attached to a structure type through the
@scheme[prop:custom-write] property. In particular, recursive printing
can trigger an escape from the call. See @scheme[prop:custom-write]
for more information.}
can trigger an escape from the call.
See @scheme[prop:custom-write] for more information. The
@scheme[printable<%>] interface is implemented with
@scheme[interface*] and @scheme[prop:custom-write].}
@; ------------------------------------------------------------------------

21
collects/scribblings/reference/cont.scrbl
View File

@ -43,17 +43,18 @@ between the application and the current continuation.
@defproc[(call-with-continuation-prompt
[thunk (-> any)]
[proc procedure?]
[prompt-tag continuation-prompt-tag? (default-continuation-prompt-tag)]
[handler (or/c procedure? #f) #f])
[handler (or/c procedure? #f) #f]
[arg any/c] ...)
any]{
Calls @scheme[thunk] with the current continuation extended by a
prompt. The prompt is tagged by @scheme[prompt-tag], which must be a
result from either @scheme[default-continuation-prompt-tag] (the
default) or @scheme[make-continuation-prompt-tag]. The result of
@scheme[thunk] is the result of the
@scheme[call-with-continuation-prompt] call.
Applies @scheme[proc] to the given @scheme[arg]s with the current
continuation extended by a prompt. The prompt is tagged by
@scheme[prompt-tag], which must be a result from either
@scheme[default-continuation-prompt-tag] (the default) or
@scheme[make-continuation-prompt-tag]. The result of @scheme[proc] is
the result of the @scheme[call-with-continuation-prompt] call.
The @scheme[handler] argument specifies a handler procedure to be
called in tail position with respect to the
@ -62,8 +63,8 @@ is the target of a @scheme[abort-current-continuation] call with
@scheme[prompt-tag]; the remaining arguments of
@scheme[abort-current-continuation] are supplied to the handler
procedure. If @scheme[handler] is @scheme[#f], the default handler
accepts a single @scheme[abort-thunk] argument and calls
@scheme[(call-with-continuation-prompt abort-thunk prompt-tag #f)];
accepts a single @scheme[_abort-thunk] argument and calls
@scheme[(call-with-continuation-prompt _abort-thunk prompt-tag #f)];
that is, the default handler re-installs the prompt and continues with
a given thunk.}

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

@ -363,7 +363,7 @@ results or completely unspecified results (the latter when
@scheme[any] is specified).
Each @scheme[dom-expr] is a contract on an argument to a
function, and each @scheme[res-expr] is a contract on a
function, and each @scheme[range-expr] is a contract on a
result of the function.
@margin-note{Using an @scheme[->] between two whitespace-delimited
@ -395,7 +395,7 @@ contract checking is performed on the result of the function, and
thus any number of values is legal (even different numbers on different
invocations of the function).
If @scheme[(values res-expr ...)] is used as the last sub-form of
If @scheme[(values range-expr ...)] is used as the last sub-form of
@scheme[->], the function must produce a result for each contract, and
each values must match its respective contract.}
@ -494,10 +494,10 @@ just like that for @scheme[->] and @scheme[->*].
}
@defform[(unconstrained-domain-> res-expr ...)]{
@defform[(unconstrained-domain-> range-expr ...)]{
Constructs a contract that accepts a function, but makes no constraint
on the function's domain. The @scheme[res-expr]s determine the number
on the function's domain. The @scheme[range-expr]s determine the number
of results and the contract for each result.
Generally, this contract must be combined with another contract to

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

@ -138,7 +138,8 @@ message.}
@defproc[(raise-syntax-error [name (or/c symbol? #f)]
[message string?]
[expr any/c #f]
[sub-expr any/c #f])
[sub-expr any/c #f]
[extra-sources (listof syntax?) null])
any]{
Creates an @scheme[exn:fail:syntax] value and @scheme[raise]s it as an
@ -151,12 +152,19 @@ is provided; it is described in more detail below. The
The optional @scheme[expr] argument is the erroneous source syntax
object or S-expression. The optional @scheme[sub-expr] argument is a
syntax object or S-expression within @scheme[expr] that more precisely
locates the error. If @scheme[sub-expr] is provided, it is used (in
syntax form) for the @scheme[exprs] field of the generated exception
record, else the @scheme[expr] is used if provided, otherwise the
@scheme[exprs] field is the empty list. Source location information in
the error-message text is similarly extracted from @scheme[sub-expr]
or @scheme[expr], when at least one is a syntax object.
locates the error. Both may appear in the generated error-message
text if @scheme[error-print-source-location] is @scheme[#t]. Source
location information in the error-message text is similarly extracted
from @scheme[sub-expr] or @scheme[expr] when at least one is a syntax
object and @scheme[error-print-source-location] is @scheme[#t].
If @scheme[sub-expr] is provided, it is used (in syntax form) for the
@scheme[exprs] field of the generated exception record, else the
@scheme[expr] is used if provided. In either case, the syntax object
is @scheme[cons]ed onto @scheme[extra-sources] to produce the
@scheme[exprs] field, or @scheme[extra-sources] is used directly for
@scheme[exprs] if neither @scheme[expr] nor @scheme[sub-expr] is
provided.
The form name used in the generated error message is determined
through a combination of the @scheme[name], @scheme[expr], and
@ -177,9 +185,7 @@ through a combination of the @scheme[name], @scheme[expr], and
@item{@scheme[symbol]: When @scheme[name] is a symbol, then the symbol
is used as the form name in the generated error message.}
}
See also @scheme[error-print-source-location].}
}}
@;------------------------------------------------------------------------
@section{Handling Exceptions}

2
collects/scribblings/reference/match.scrbl
View File

@ -8,6 +8,8 @@
@title[#:tag "match"]{Pattern Matching}
@guideintro["match"]{pattern matching}
The @scheme[match] form and related forms support general pattern
matching on Scheme values. See also @secref["regexp"] for information
on regular-expression matching on strings, bytes, and streams.

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

@ -672,6 +672,28 @@ returns @scheme[#f].
(filter-not even? '(1 2 3 4 5 6))
]}
@defproc[(argmin [proc (-> any/c real?)] [lst (and/c pair? list?)]) any/c]{
This returns the first element in the list @scheme[lst] that minimizes
the result of @scheme[proc].
@mz-examples[#:eval list-eval
(argmin car '((3 pears) (1 banana) (2 apples)))
(argmin car '((1 banana) (1 orange)))
]
}
@defproc[(argmax [proc (-> any/c real?)] [lst (and/c pair? list?)]) any/c]{
This returns the first element in the list @scheme[lst] that maximizes
the result of @scheme[proc].
@mz-examples[#:eval list-eval
(argmax car '((3 pears) (1 banana) (2 apples)))
(argmax car '((3 pears) (3 oranges)))
]
}
@close-eval[list-eval]
@; ----------------------------------------

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

@ -3,6 +3,8 @@
@title[#:tag "parameters"]{Parameters}
@guideintro["parameterize"]{parameters}
See @secref["parameter-model"] for basic information on the
parameter model. Parameters correspond to @defterm{preserved thread
fluids} in Scsh @cite["Gasbichler02"].
@ -45,6 +47,8 @@ applied to the initial @scheme[v].}
@defform[(parameterize ((parameter-expr value-expr) ...)
body ...+)]{
@guideintro["parameterize"]{@scheme[parameterize]}
The result of a @scheme[parameterize] expression is the result of the
last @scheme[body]. The @scheme[parameter-expr]s determine the
parameters to set, and the @scheme[value-expr]s determine the

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

@ -46,6 +46,15 @@ function consumes.
((compose list split-path) (bytes->path #"/a" 'unix))
]}
@defproc[(procedure-rename [proc procedure?]
[name symbol?])
procedure?]{
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].}
@; ----------------------------------------
@section{Keywords and Arity}

30
collects/scribblings/reference/regexps.scrbl
View File

@ -23,7 +23,7 @@ port, it matches UTF-8 encodings (see @secref["encodings"]) of
matching character streams; if a byte regexp is used with a character
string, it matches bytes in the UTF-8 encoding of the string.
Regular expressions can be compiled into a @defterm{regexp value} for
Regular expressions can be compiled into a @deftech{regexp value} for
repeated matches. The @scheme[regexp] and @scheme[byte-regexp]
procedures convert a string or byte string (respectively) into a
regexp value using one syntax of regular expressions that is most
@ -103,25 +103,25 @@ arbitrarily large sequence).
@defproc[(regexp? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a regexp value created by
Returns @scheme[#t] if @scheme[v] is a @tech{regexp value} created by
@scheme[regexp] or @scheme[pregexp], @scheme[#f] otherwise.}
@defproc[(pregexp? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a regexp value created by
Returns @scheme[#t] if @scheme[v] is a @tech{regexp value} created by
@scheme[pregexp] (not @scheme[regexp]), @scheme[#f] otherwise.}
@defproc[(byte-regexp? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a regexp value created by
Returns @scheme[#t] if @scheme[v] is a @tech{regexp value} created by
@scheme[byte-regexp] or @scheme[byte-pregexp], @scheme[#f] otherwise.}
@defproc[(byte-pregexp? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a regexp value created by
Returns @scheme[#t] if @scheme[v] is a @tech{regexp value} created by
@scheme[byte-pregexp] (not @scheme[byte-regexp]), @scheme[#f]
otherwise.}
@ -129,15 +129,15 @@ otherwise.}
@defproc[(regexp [str string?]) regexp?]{
Takes a string representation of a regular expression (using the
syntax in @secref["regexp-syntax"]) and compiles it into a regexp
value. Other regular expression procedures accept either a string or a
regexp value as the matching pattern. If a regular expression string
syntax in @secref["regexp-syntax"]) and compiles it into a @tech{regexp
value}. Other regular expression procedures accept either a string or a
@tech{regexp value} as the matching pattern. If a regular expression string
is used multiple times, it is faster to compile the string once to a
regexp value and use it for repeated matches instead of using the
@tech{regexp value} and use it for repeated matches instead of using the
string each time.
The @scheme[object-name] procedure returns
the source string for a regexp value.
the source string for a @tech{regexp value}.
@examples[
(regexp "ap*le")
@ -160,10 +160,10 @@ Like @scheme[regexp], except that it uses a slightly different syntax
Takes a byte-string representation of a regular expression (using the
syntax in @secref["regexp-syntax"]) and compiles it into a
byte-regexp value.
byte-@tech{regexp value}.
The @scheme[object-name] procedure
returns the source byte string for a regexp value.
returns the source byte string for a @tech{regexp value}.
@examples[
(byte-regexp #"ap*le")
@ -210,8 +210,8 @@ case-sensitively.
(listof (or/c bytes? #f))
#f)]{
Attempts to match @scheme[pattern] (a string, byte string, regexp
value, or byte-regexp value) once to a portion of @scheme[input]. The
Attempts to match @scheme[pattern] (a string, byte string, @tech{regexp
value}, or byte-@tech{regexp value}) once to a portion of @scheme[input]. The
matcher finds a portion of @scheme[input] that matches and is closest
to the start of the input (after @scheme[start-pos]).
@ -236,7 +236,7 @@ end-of-input @litchar{$} refers to the @scheme[end-pos]th position or
If the match fails, @scheme[#f] is returned. If the match succeeds, a
list containing strings or byte string, and possibly @scheme[#f], is
returned. The list contains strings only if @scheme[input] is a string
and @scheme[pattern] is not a byte regexp value. Otherwise, the list
and @scheme[pattern] is not a byte regexp. Otherwise, the list
contains byte strings (substrings of the UTF-8 encoding of
@scheme[input], if @scheme[input] is a string).

24
collects/scribblings/reference/rx.ss
View File

@ -49,20 +49,26 @@ Range ::= ] Range contains _]_ only
| Mrange- Range contains _-_ and everything in Mrange #co
Mrange ::= ]Lrange Mrange contains _]_ and everything in Lrange #co
| -Lrange Mrange contains _-_ and everything in Lrange #co
| Lrange Mrange contains everything in Lrange #co
Lrange ::= Rliteral Lrange contains a literal character #co
| Srange Mrange contains everything in Srange #co
Srange ::= Sliteral Srange contains a literal character #co
| Sliteral-Rliteral Srange contains Unicode range inclusive #co
| SrangeLrange Srange contains everything in both #co
Lrange ::= ^ Lrange contains _^_ #co
| Rliteral-Rliteral Lrange contains Unicode range inclusive #co
| LrangeLrange Lrange contains everything in both #co
| ^Lrange Lrange contains _^_ and more #co
| Srange Lrange contains everything in Srange #co
Look ::= (?=Regexp) Match if Regexp matches #mode
| (?!Regexp) Match if Regexp doesn't match #mode
| (?<=Regexp) Match if Regexp matches preceeding #mode
| (?<!Regexp) Match if Regexp doesn't match preceeding #mode
Pred ::= (N) True if Nth _(_ has a match #mode
| Look True if Look matches #mode
Lrange ::= ... ... #px
| Class Lrange contains all characters in Class #px
| Posix Lrange contains all characters in Posix #px
| \\Eliteral Lrange contains Eliteral #px
Srange ::= ... ... #px
| Class Srange contains all characters in Class #px
| Posix Srange contains all characters in Posix #px
| \\Eliteral Srange contains Eliteral #px
Sliteral :== Any character except _]_, _-_, or _^_ #rx
Sliteral :== Any character except _]_, _\\_, _-_, or _^_ #px
Rliteral :== Any character except _]_ or _-_ #rx
Rliteral :== Any character except _]_, _\\_, or _-_ #px
Eliteral :== Any character except _a_-_z_, _A_-_Z_ #px
@ -119,12 +125,14 @@ Category ::= Ll | Lu | Lt | Lm Unicode general category
[(equal? s "range") "rng"]
[(equal? s "mrange") "mrng"]
[(equal? s "lrange") "lrng"]
[(equal? s "srange") "lirng"]
[(equal? s "sliteral") "riliteral"]
[(equal? s "pred") "tst"]
[else s]))
(define (fixup-ids s)
(let loop ([m (regexp-match-positions
#px"(Regexp)|(Pieces?)|(Atom)|(Repeat)|(Literal)|(Aliteral)|(Eliteral)|(Range)|(Lrange)|(Mrange)|(Rliteral)|(Mode)|(Class)|(Posix)|(Property)|(Category)|(Pred)|(Look)|(\\bN\\b)|(\\bM\\b)"
#px"(Regexp)|(Pieces?)|(Atom)|(Repeat)|(Literal)|(Aliteral)|(Eliteral)|(Range)|(Srange)|(Lrange)|(Mrange)|(Sliteral)|(Rliteral)|(Mode)|(Class)|(Posix)|(Property)|(Category)|(Pred)|(Look)|(\\bN\\b)|(\\bM\\b)"
s)])
(cond
[m

28
collects/scribblings/reference/struct-inspectors.scrbl
View File

@ -141,10 +141,26 @@ is not controlled by the current inspector, the
Returns a value for the name of @scheme[v] if @scheme[v] has a name,
@scheme[#f] otherwise. The argument @scheme[v] can be any value, but
only (some) procedures, structs, struct types, struct type properties,
regexp values, and ports have names. The name of a procedure, struct,
struct type, or struct type property is always a symbol. The name of a
regexp value is a string, and a byte-regexp value's name is a byte
string. The name of a port is typically a path or a string, but it can
be arbitrary. See also @secref["infernames"].}
only (some) procedures, @tech{structures}, @tech{structure types},
@tech{structure type properties}, @tech{regexp values}, and
@tech{ports} have names. See also @secref["infernames"].
The name (if any) of a procedure is always a symbol. The
@scheme[procedure-rename] function creates a procedure with a specific
name.
The name of a @tech{structure}, @tech{structure type}, @tech{structure
type property} is always a symbol. If a @tech{structure} is not a
procedure, its name matches the name of the @tech{structure type} that
it instantiates.
The name of a @tech{regexp value} is a string or byte string. Passing
the string or byte string to @scheme[regexp], @scheme[byte-regexp],
@scheme[pregexp], or @scheme[byte-pregexp] (depending on the kind of
regexp whose name was extracted) produces a value that matches the
same inputs.
The name of a port can be any value, but many tools use a path or
string name as the port's for (to report source locations, for
example).}

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

@ -8,8 +8,6 @@
@guideintro["define-struct"]{structure types via @scheme[define-struct]}
@local-table-of-contents[]
A @deftech{structure type} is a record datatype composing a number of
@idefterm{fields}. A @deftech{structure}, an instance of a structure
type, is a first-class value that contains a value for each field of
@ -74,6 +72,8 @@ results of applying @scheme[struct->vector] to the structs are
@scheme[equal?]. (Consequently, @scheme[equal?] testing for
structures depends on the current inspector.)
@local-table-of-contents[]
@;------------------------------------------------------------------------
@include-section["define-struct.scrbl"]

1
collects/scribblings/reference/syntax.scrbl
View File

@ -1335,6 +1335,7 @@ position with respect to the @scheme[if] form.
@mz-examples[
(if (positive? -5) (error "doesn't get here") 2)
(if (positive? 5) 1 (error "doesn't get here"))
(if 'we-have-no-bananas "yes" "no")
]}
@defform/subs[#:literals (else =>)

33
collects/scribblings/reference/units.scrbl
View File

@ -89,24 +89,25 @@ ways:
As an export, this form causes definitions using the @scheme[id]
prefix to satisfy the exports required by @scheme[sig-spec].}
@item{@scheme[(rename sig-spec (id id) ...)] as
an import binds the same as @scheme[sig-spec], except that the first @scheme[id]
is used for the binding instead of the second @scheme[id] (where
@scheme[sig-spec] by itself must imply a binding for the second @scheme[id]).
As an export, this form causes a definition for the first @scheme[id]
to satisfy the export named by the second @scheme[id] in @scheme[sig-spec].}
@item{@scheme[(rename sig-spec (id id) ...)] as an import binds the
same as @scheme[sig-spec], except that the first @scheme[id] is used
for the binding instead of the second @scheme[id] (where
@scheme[sig-spec] by itself must imply a bindingthat is
@scheme[bound-identifier=?] to second @scheme[id]). As an export,
this form causes a definition for the first @scheme[id] to satisfy
the export named by the second @scheme[id] in @scheme[sig-spec].}
@item{@scheme[(only sig-spec id ...)] as
an import binds the same as @scheme[sig-spec], but restricted to just the
listed @scheme[id]s (where
@scheme[sig-spec] by itself must imply a binding for each @scheme[id]).
This form is not allowed for an export.}
@item{@scheme[(only sig-spec id ...)] as an import binds the same as
@scheme[sig-spec], but restricted to just the listed @scheme[id]s
(where @scheme[sig-spec] by itself must imply a binding that is
@scheme[bound-identifier=?] to each @scheme[id]). This form is not
allowed for an export.}
@item{@scheme[(except sig-spec id ...)] as
an import binds the same as @scheme[sig-spec], but excluding all listed
@scheme[id]s (where
@scheme[sig-spec] by itself must imply a binding for each @scheme[id]).
This form is not allowed for an export.}
@item{@scheme[(except sig-spec id ...)] as an import binds the same
as @scheme[sig-spec], but excluding all listed @scheme[id]s (where
@scheme[sig-spec] by itself must imply a binding that is
@scheme[bound-identifier=?] to each @scheme[id]). This form is not
allowed for an export.}
}

59
collects/teachpack/2htdp/scribblings/balls.ss Normal file
View File

@ -0,0 +1,59 @@
;; 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 balls) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "world.ss" "htdp"))
;; constants
(define height 50)
(define delta 80)
(define width (+ delta (* 2 height)))
(define left (quotient height 2))
(define right (+ height delta left))
;; World = (make-posn left Number) | (make-posn right Number)
(define server (text "server" 11 'black))
(define server* (overlay server (nw:rectangle (image-width server) (image-height server) 'outline 'black)))
;; visual constants
(define bg
(place-image
(text "universe" 11 'green)
60 0
(place-image
server*
(+ height 15) 20
(place-image
(text "left" 11 'blue)
10 10
(place-image
(text "right" 11 'red)
(+ height delta 10) 10
(place-image
(nw:rectangle delta height 'solid 'white)
height 0
(place-image
(nw:rectangle width height 'solid 'gray)
0 0
(empty-scene width height))))))))
(define ball (circle 3 'solid 'red))
;; World -> Scene
(define (draw w)
(place-image ball (posn-x w) (posn-y w) bg))
;; World -> World
(define (tick w)
(local ((define y (posn-y w))
(define x (posn-x w)))
(cond
[(> y 0) (make-posn x (- y 1))]
[(= x left) (make-posn right height)]
[(= x right) (make-posn left height)])))
(big-bang width height 1/66 (make-posn left height) true)
(on-redraw draw)
(on-tick-event tick)

59
collects/teachpack/2htdp/scribblings/fsa.ss Normal file
View File

@ -0,0 +1,59 @@
#lang slideshow
(require slideshow/pict)
(define DELTA 40)
(define FT 12)
; (fsa "unlock" "lock" "push" "tick")
(define (fsa L C O unlock lock push tick)
(define (make-state txt)
(define t (text txt '() FT))
(define e (rounded-rectangle (+ 10 (pict-width t)) (+ 10 (pict-height t))))
(cc-superimpose t e))
(define locked (make-state L))
(define closed (make-state C))
(define open (make-state O))
(define bg (rectangle (+ (pict-width locked) (* 2 DELTA))
(+ (pict-height locked)
(pict-height closed)
(pict-height open)
(* 3 DELTA))))
(define width (pict-width bg))
(define (center base state y)
(define w (pict-width state))
(define d (quotient (- width w) 2))
(pin-over base d y state))
(define nx
(center
(center
(center
bg locked (/ DELTA 2))
closed
(+ (/ DELTA 2) (pict-height locked) DELTA))
open
(+ (/ DELTA 2) DELTA (pict-height locked) DELTA (pict-height closed))))
(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
(define-values (x0 y0) (lb-find nx locked))
(define-values (x1 y1) (lt-find nx closed))
(define lbl (text txt '() (- FT 2)))
(define wlbl (pict-width lbl))
(define hlbl (pict-height lbl))
(define x (- x0 (/ wlbl 2)))
(define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
(pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
(define l1 (add-labeled-arrow nx locked lb-find closed lt-find unlock))
(define l2 (add-labeled-arrow l1 closed lb-find open lt-find push))
(define l3 (add-labeled-arrow l2 open rt-find closed rb-find tick))
(define l4 (add-labeled-arrow l3 closed rt-find locked rb-find lock))
l4)
(fsa "locked" "closed" "open" "unlock" "lock" "push" "time")
(fsa "'locked" "'closed" "'open" "#\\u" "#\\l" "#\\space" "tick")

119
collects/teachpack/2htdp/scribblings/nuworld.ss Normal file
View File

@ -0,0 +1,119 @@
#lang slideshow
(require slideshow/pict mred/mred)
(define DELTA 80)
(define FT 12)
(define txt
'("(big-bang World_0"
" (on-draw render WIDTH HEIGHT)"
" (on-tick tock RATE)"
" (on-mouse click)"
" (on-key react))"
))
(define program
(apply vl-append (map (lambda (t) (text t '() (- FT 2))) txt)))
(define Program
(cc-superimpose
(rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
program))
(define (make-state txt)
(define t (text txt '() FT))
(define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))
(cc-superimpose t e))
(define False (text "FALSE" '() FT))
(define True (text "TRUE" '() FT))
(define BOOL (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False))))
;; String Boolean -> Pict
(define (make-state0 txt b)
;; create the basic state
(define t (text txt '() FT))
(define s (if b
(cc-superimpose
(rounded-rectangle (+ 5 (pict-width t)) (+ (- DELTA 5) (pict-height t)))
t)
t))
(define w
(cc-superimpose
s
(rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
;; add the boolean
(define bb (cc-superimpose (if b True False) BOOL))
(define ar (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done"))
(define scene (text "Scene" '() FT))
(define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene)))))
(define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render"))
br)
(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
(define-values (x0 y0) (lb-find nx locked))
(define-values (x1 y1) (lt-find nx closed))
(define lbl (text txt '() (- FT 2)))
(define wlbl (pict-width lbl))
(define hlbl (pict-height lbl))
(define x (- x0 (/ wlbl 2)))
(define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
(pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
(define (h-labeled-arrow t)
(define tock (text t '() (- FT 2)))
(define blk (blank (+ DELTA 4) 2))
(vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find)))
(define arrows
(vc-append (h-labeled-arrow "tock")
(h-labeled-arrow "click")
(h-labeled-arrow "react")))
(define state0 (make-state0 "World_0" #f))
(define state1 (make-state0 "World_1" #f))
(define dots (cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT)))
(define state2 (make-state0 "World_N-1" #f))
(define stateN (make-state0 "World_N" #t))
(define states (list state0 arrows state1 arrows dots arrows state2 arrows stateN))
(define bg (blank (+ (apply + (map pict-width states))
DELTA #;(* (length states) DELTA))
(+ (pict-height state0) DELTA)))
(define (center base state x)
(define w (pict-height state))
(define d (quotient (- width w) 2))
(pin-over base x d state))
(define width (pict-height bg))
(define x (* 1/2 DELTA))
(define xx
(foldl (lambda (f ls s)
(define y (center s f x))
(set! x (+ x ls))
y)
bg
states
(map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states)))
(define the-image (ct-superimpose xx Program))
(define image-bm
(make-object bitmap%
(inexact->exact (round (pict-width the-image)))
(inexact->exact (round (pict-height the-image)))))
(send image-bm ok?)
(define image-dc
(new bitmap-dc% [bitmap image-bm]))
(send image-dc clear)
(draw-pict the-image image-dc 0.0 0.0)
(send image-bm save-file "nuworld.png" 'png)
the-image

181
collects/teachpack/2htdp/scribblings/server2.ss Normal file
View File

@ -0,0 +1,181 @@
#lang slideshow
(require slideshow/pict)
(define DELTA 80)
(define FT 12)
(define initialize "register")
(define proc-msg "process")
(define program
(apply vl-append (map (lambda (t) (text t '() (- FT 2)))
(list (format "(universe ~a ~a)" initialize proc-msg)))))
(define Program
(cc-superimpose
(rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
program))
;; String Boolean -> Pict
(define (make-state0 txt b)
;; create the basic state
(define t (text txt '() FT))
(cc-superimpose t (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
(define-values (x0 y0) (lb-find nx locked))
(define-values (x1 y1) (lt-find nx closed))
(define lbl (text txt '() (- FT 2)))
(define wlbl (pict-width lbl))
(define hlbl (pict-height lbl))
(define x (- x0 (/ wlbl 2)))
(define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
(pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
(define (h-labeled-arrow t)
(define tock (text t '() (- FT 2)))
(define blk (blank (+ DELTA 4) 2))
(vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find)))
(define message (text "Message" '() FT))
(define (make-Message)
(cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message)))))
(define Message (vc-append (make-Message) (arrowhead 4 (* 1/2 pi))))
(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
(define MessageI (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
(define M (rb-superimpose Message (blank DELTA DELTA)))
(define K (rb-superimpose MessageK (blank DELTA DELTA)))
(define I (rb-superimpose MessageI (blank DELTA DELTA)))
(define (make-arrows M lbl)
(define Tock (h-labeled-arrow lbl))
(values Tock (vc-append (blank DELTA (/ DELTA 2)) Tock M)))
(define-values (TockM arrowsR) (make-arrows M proc-msg))
(define-values (TockK arrowsL) (make-arrows K proc-msg))
(define-values (init arrows) (make-arrows I initialize))
(define state0 (make-state0 "Server_0" #f))
(define state2 (make-state0 "Server_N-1" #f))
(define Univrs (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "Universe" '() FT ))))
(define dots (vc-append
(blank (pict-width state2) (quotient (pict-height state2) 1))
(text "..." '() FT)
(blank (pict-width state2) (* (pict-height state2)))
Univrs))
(define states (list arrows
state0
arrowsL
dots
arrowsR
state2
(h-labeled-arrow proc-msg)))
(define bg (blank (+ (apply + (map pict-width states)) DELTA) (pict-height dots)))
(define (center base state x)
(define w (pict-height state))
(define d (quotient (- (pict-height bg) w) 2))
(pin-over base x d state))
(define x (* 1/2 DELTA))
(define xx
(foldl (lambda (f ls s)
(define y (center s f x))
(set! x (+ x ls))
y)
bg
states
(map pict-width states)))
(define zz (ct-superimpose xx Program))
(require mred/mred)
(define the-image
(lt-superimpose
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz MessageK))
(define-values (tx ty) (ct-find zz MessageK))
(define-values (ix iy) (ct-find zz MessageI))
(define-values (jx jy) (cb-find zz MessageI))
(define-values (sx sy) (lc-find zz Univrs))
(define-values (tockx tocky) (lb-find zz TockK))
(define-values (initx inity) (lb-find zz init))
(define (add-curve rx ry)
(set! dcp (make-object dc-path%))
(set! cx (max rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (min sx mx))
(define cy (max sy my))
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
(set! dcp (make-object dc-path%))
(set! cx (min sx jx))
(set! cy (max sy jy))
(send dc set-smoothing 'aligned)
(send dcp move-to jx jy)
(send dcp curve-to jx jy cx cy sx sy)
(send dc draw-path dcp)
;; --- draw arc from Message to Receiver
(add-curve tockx tocky)
(set! tx ix) (set! ty iy)
(add-curve initx inity)
;; ---
dc)
(pict-width zz) (pict-height zz))
(lt-superimpose
zz
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz Message))
(define-values (tx ty) (ct-find zz Message))
(define-values (sx sy) (rc-find zz Univrs))
(define-values (tockx tocky) (rb-find zz TockM))
(define (add-curve rx ry)
(set! dcp (make-object dc-path%))
(set! cx (min rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (max sx mx))
(define cy (max sy my))
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
;; --- draw arc from Message to Receiver
(add-curve tockx tocky)
;; ---
dc)
(pict-width zz) (pict-height zz)))))
(define image-bm
(make-object bitmap%
(inexact->exact (round (pict-width the-image)))
(inexact->exact (round (pict-height the-image)))))
(send image-bm ok?)
(define image-dc
(new bitmap-dc% [bitmap image-bm]))
(send image-dc clear)
(draw-pict the-image image-dc 0.0 0.0)
(send image-bm save-file "server2.png" 'png)
the-image

10
collects/teachpack/2htdp/scribblings/shared.ss Normal file
View File

@ -0,0 +1,10 @@
#lang scheme/base
(require scribble/manual)
(provide teachpack)
(define (teachpack tp . name)
(apply title #:tag tp
`(,@name ": " ,(filepath (format "~a.ss" tp))
,(index (format "~a teachpack" tp)))))

1536
collects/teachpack/2htdp/scribblings/universe.scrbl Normal file
View File

File diff suppressed because it is too large Load Diff

200
collects/teachpack/2htdp/scribblings/universe.ss Normal file
View File

@ -0,0 +1,200 @@
#lang slideshow
(require slideshow/pict)
(define DELTA 80)
(define FT 12)
(define prgm
'("(big-bang World_0"
" (on-draw render WIDTH HEIGHT)"
" (on-tick tock RATE)"
" (on-mouse click)"
" (on-key react)"
" (on-receive receive)"
" (register LOCALHOST 'jimbob))"))
(define program
(apply vl-append (map (lambda (t) (text t '() (- FT 2))) prgm)))
(define Program
(cc-superimpose
(rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
program))
(define (make-state txt)
(define t (text txt '() FT))
(define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))
(cc-superimpose t e))
(define False (text "FALSE" '() FT))
(define True (text "TRUE" '() FT))
(define BOOL (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False))))
;; String Boolean -> Pict
(define (make-state0 txt b)
;; create the basic state
(define t (text txt '() FT))
(define s (if b
(cc-superimpose
(rounded-rectangle (+ 5 (pict-width t)) (+ (- DELTA 5) (pict-height t)))
t)
t))
(define w
(cc-superimpose
s
(rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
;; add the boolean
(define bb (cc-superimpose (if b True False) BOOL))
(define ar (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done"))
(define scene (text "Scene" '() FT))
(define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene)))))
(define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render"))
br)
(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
(define-values (x0 y0) (lb-find nx locked))
(define-values (x1 y1) (lt-find nx closed))
(define lbl (text txt '() (- FT 2)))
(define wlbl (pict-width lbl))
(define hlbl (pict-height lbl))
(define x (- x0 (/ wlbl 2)))
(define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
(pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
(define (h-labeled-arrow t)
(define tock (text t '() (- FT 2)))
(define blk (blank (+ DELTA 4) 2))
(vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find)))
(define message (text "Message" '() FT))
(define (make-Message)
(cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message)))))
(define Message (vc-append (make-Message) (arrowhead 4 (* 1/2 pi))))
(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
(define M (rb-superimpose Message (blank DELTA DELTA)))
(define K (rb-superimpose MessageK (blank DELTA DELTA)))
(define (make-arrows M)
(define Tock (h-labeled-arrow "tock"))
(define Click (h-labeled-arrow "click"))
(define Clack (h-labeled-arrow "react"))
(define Receive (h-labeled-arrow "receive"))
(values Tock Click Clack Receive (vc-append (blank DELTA (/ DELTA 2)) Tock Click Clack Receive M)))
(define-values (TockM ClickM ClackM ReceiveM arrowsR) (make-arrows M))
(define-values (TockK ClickK ClackK ReceiveK arrowsL) (make-arrows K))
(define state0 (make-state0 "World_0" #f))
(define state1 (make-state0 "World_1" #f))
(define Server (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "SERVER" '() FT ))))
(define dots (vc-append
(cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT))
Server))
(define state2 (make-state0 "World_N-1" #f))
(define stateN (make-state0 "World_N" #t))
(define states (list state1 arrowsL dots arrowsR state2))
(define bg (blank (+ (apply + (map pict-width states)) DELTA)
(+ (pict-height state0) DELTA)))
(define (center base state x)
(define w (pict-height state))
(define d (quotient (- width w) 2))
(pin-over base x d state))
(define width (pict-height bg))
(define x (* 1/2 DELTA))
(define xx
(foldl (lambda (f ls s)
(define y (center s f x))
(set! x (+ x ls))
y)
bg
states
(map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states)))
(define zz xx)
(require mred/mred)
(define the-image
(ct-superimpose Program
(lt-superimpose
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz MessageK))
(define-values (tx ty) (ct-find zz MessageK))
(define-values (sx sy) (lc-find zz Server))
(define-values (tockx tocky) (lb-find zz TockK))
(define-values (clickx clicky) (lb-find zz ClickK))
(define-values (clackx clacky) (lb-find zz ClackK))
(define-values (rx ry) (lb-find zz ReceiveK))
(define (add-curve rx ry)
(set! dcp (make-object dc-path%))
(set! cx (max rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (min sx mx))
(define cy (max sy my))
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
;; --- draw arc from Message to Receiver
(add-curve tockx tocky)
(add-curve clickx clicky)
(add-curve clackx clacky)
(add-curve rx ry)
;; ---
dc)
(pict-width zz) (pict-height zz))
(lt-superimpose
zz
(dc (lambda (dc x y)
(define-values (mx my) (cb-find zz Message))
(define-values (tx ty) (ct-find zz Message))
(define-values (sx sy) (rc-find zz Server))
(define-values (rx ry) (rb-find zz ReceiveM))
(define dcp (make-object dc-path%))
;; --- draw arc from Message to Server
(define cx (max sx mx))
(define cy (max sy my))
(send dc set-smoothing 'aligned)
(send dcp move-to mx my)
(send dcp curve-to mx my cx cy sx sy)
(send dc draw-path dcp)
;; --- draw arc from Message to Receiver
(set! dcp (make-object dc-path%))
(set! cx (min rx tx))
(set! cy (min ry ty))
(send dcp move-to tx ty)
(send dcp curve-to tx ty cx cy rx ry)
(send dc draw-path dcp)
;; ---
dc)
(pict-width zz) (pict-height zz))))))
(define image-bm
(make-object bitmap%
(inexact->exact (round (pict-width the-image)))
(inexact->exact (round (pict-height the-image)))))
(send image-bm ok?)
(define image-dc
(new bitmap-dc% [bitmap image-bm]))
(send image-dc clear)
(draw-pict the-image image-dc 0.0 0.0)
(send image-bm save-file "universe.png" 'png)
the-image

3
collects/teachpack/2htdp/universe.ss Normal file
View File

@ -0,0 +1,3 @@
(module universe mzscheme
(provide (all-from 2htdp/universe))
(require 2htdp/universe))

BIN
collects/teachpack/balls.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 211 KiB

BIN
collects/teachpack/nuworld.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 15 KiB

BIN
collects/teachpack/server2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 17 KiB

BIN
collects/teachpack/universe.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 28 KiB

BIN
collects/teachpack/universe2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 19 KiB

4
collects/tests/drscheme/language-test.ss
View File

@ -59,7 +59,7 @@ the settings above should match r5rs
(test-expression "'|.|" "|.|")
(test-expression '("(equal? (list " image ") (list " image "))")
"#f")
"#t")
(test-expression "(define x 1)(define x 2)" "")
(test-expression "(define-struct spider (legs))(make-spider 4)" "#<spider>")
@ -159,7 +159,7 @@ the settings above should match r5rs
(test-expression "'|.|" "|.|")
(test-expression '("(equal? (list " image ") (list " image "))")
"#f")
"#t")
(test-expression "(define x 1)(define x 2)" "")
(test-expression

8
collects/tests/mzscheme/basic.ss
View File

@ -2366,7 +2366,9 @@
(check-ok + (list 4 (make-arity-at-least 2)) '(2 3 4 10) '(0 1))
(check-ok + (list 2 (make-arity-at-least 4)) '(2 4 10) '(0 1 3)))])
(check-all-but-one +)
(check-all-but-one (procedure-rename + 'plus))
(check-all-but-one (lambda args (apply + args)))
(check-all-but-one (procedure-rename (lambda args (apply + args)) 'PLUS))
(check-all-but-one (case-lambda
[() 0]
[(a b . args) (apply + a b args)]))
@ -2386,6 +2388,12 @@
[() 0]
[(a b c d . e) (apply + a b c d e)]))))
(test '+ object-name (procedure-reduce-arity + 3))
(test 'plus object-name (procedure-rename + 'plus))
(test 'again object-name (procedure-rename (procedure-rename + 'plus) 'again))
(test 'again object-name (procedure-rename (procedure-reduce-arity + 3) 'again))
(test 3 procedure-arity (procedure-rename (procedure-reduce-arity + 3) 'again))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

4
collects/tests/mzscheme/htdp-image.ss
View File

@ -1021,6 +1021,10 @@
(image? image-snip2))
(test #t
'bs-image=?
(image=? image-snip1 (send image-snip1 copy)))
(test #f
'bs-image=?
;; They have different masks:
(image=? image-snip1 image-snip2))
(test 2
'bs-image-width

55
collects/tests/mzscheme/list.ss
View File

@ -270,6 +270,61 @@
(test '(1 2 3) am list '(1 2 3))
(test '(1 1 2 2 3 3) am (lambda (x) (list x x)) '(1 2 3)))
;; ---------- argmin & argmax ----------
(let ()
(define ((check-regs . regexps) exn)
(and (exn:fail? exn)
(andmap (λ (reg) (regexp-match reg (exn-message exn)))
regexps)))
(test 'argmin object-name argmin)
(test 1 argmin (lambda (x) 0) (list 1))
(test 1 argmin (lambda (x) x) (list 1 2 3))
(test 1 argmin (lambda (x) 1) (list 1 2 3))
(test 3
'argmin-makes-right-number-of-calls
(let ([c 0])
(argmin (lambda (x) (set! c (+ c 1)) 0)
(list 1 2 3))
c))
(test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples)))
(err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure"))
(err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list"))
(err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list"))
(test 'argmax object-name argmax)
(test 1 argmax (lambda (x) 0) (list 1))
(test 3 argmax (lambda (x) x) (list 1 2 3))
(test 1 argmax (lambda (x) 1) (list 1 2 3))
(test 3
'argmax-makes-right-number-of-calls
(let ([c 0])
(argmax (lambda (x) (set! c (+ c 1)) 0)
(list 1 2 3))
c))
(test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples)))
(err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure"))
(err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list"))
(err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list")))
;; ---------- check no collisions with srfi/1 ----------
(test (void)
eval '(module foo scheme/base (require scheme/base srfi/1/list))

57
collects/tests/mzscheme/object.ss
View File

@ -1413,6 +1413,63 @@
(check #f #t)
(check #t #t))
;; ----------------------------------------
;; Implementing equal<%>
(let ()
(define c%
(class* object% (equal<%>)
(init-field x)
(define/public (get-x) x)
(define/public (set-x v) (set! x v))
(define/public (equal-to? other recur-equal?)
(recur-equal? x (send other get-x)))
(define/public (equal-hash-code-of recur-hash-code)
(+ 1 (recur-hash-code x)))
(define/public (equal-secondary-hash-code-of recur-hash-code)
(+ 1 (recur-hash-code x)))
(super-new)))
(test #t equal? (new c% [x 10]) (new c% [x 10]))
(test #f equal? (new c% [x 10]) (new c% [x 12]))
(let ([o (new c% [x 10])]
[o2 (new c% [x 10])])
(send o set-x o)
(send o2 set-x o2)
(test #t equal? o o2)
(test #t equal? o (new c% [x o]))
(test #f equal? o (new c% [x 10]))
(let ([ht (make-hash)])
(hash-set! ht o o)
(hash-set! ht (new c% [x "hello"]) 'hi)
(test #t eq? o (hash-ref ht o2))
(test #f hash-ref ht (new c% [x 10]) #f)
(test 'hi hash-ref ht (new c% [x "hello"]))
(let ([d% (class c%
(super-new [x "hello"]))])
(test 'hi hash-ref ht (new d%) #f))
(let ([d% (class* c% (equal<%>)
(super-new [x "hello"]))])
(test 'nope hash-ref ht (new d%) 'nope)))))
;; ----------------------------------------
;; Implementing new properties
(let ()
(define proc<%>
(interface* ()
([prop:procedure (lambda (o . args)
(send/apply o apply args))])
apply))
(define c%
(class* object% (proc<%>)
(define/public (apply . args)
(cons 'applied-to args))
(super-new)))
(test '(applied-to 1 2 3) (new c%) 1 2 3))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

11
collects/tests/mzscheme/prompt.ss
View File

@ -8,6 +8,17 @@
(define (test-breaks-ok)
(err/rt-test (break-thread (current-thread)) exn:break?))
(test (void) call-with-continuation-prompt void)
(test (void) call-with-continuation-prompt void (default-continuation-prompt-tag))
(test (void) call-with-continuation-prompt void (default-continuation-prompt-tag) list)
(test '() call-with-continuation-prompt list (default-continuation-prompt-tag) void)
(test '(1) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1)
(test '(1 2) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1 2)
(test '(1 2 3) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1 2 3)
(test '(1 2 3 4 5 6 7 8 9 10) call-with-continuation-prompt list (default-continuation-prompt-tag) void
1 2 3 4 5 6 7 8 9 10)
;;----------------------------------------
;; cc variants

5
collects/tests/r6rs/arithmetic/fixnums.sls
View File

@ -227,6 +227,11 @@
(test/exn (fxmod0 1 0) &assertion)
(test/exn (fxdiv0-and-mod0 1 0) &assertion)
(test/exn (fxdiv (least-fixnum) -1) &implementation-restriction)
(test/exn (fxdiv-and-mod (least-fixnum) -1) &implementation-restriction)
(test/exn (fxdiv0 (least-fixnum) -1) &implementation-restriction)
(test/exn (fxdiv0-and-mod0 (least-fixnum) -1) &implementation-restriction)
(test (fxnot 0) -1)
(test (fxnot -2) 1)
(test (fxnot 1) -2)

4
collects/tests/r6rs/io/ports.sls
View File

@ -628,7 +628,9 @@
(test (port-has-port-position? p) #t)
(test (port-has-set-port-position!? p) #t)
(test (port-position p) 0)
(test/unspec (put-string p "abc"))
(test/unspec (put-string p "ab"))
(test (port-position p) 2)
(test/unspec (put-string p "c"))
(flush-output-port p)
(test accum '(#\c #\b #\a))
(test (port-position p) 3)

20
collects/web-server/scribblings/faq.scrbl
View File

@ -1,7 +1,7 @@
#lang scribble/doc
@(require "web-server.ss")
@title{Troubleshooting}
@title{Troubleshooting and Tips}
@section{What special considerations are there for security with the Web Server?}
@ -89,3 +89,21 @@ We can now start the server with:
The Web Server will start on port 443 (which can be overridden with the @exec{-p} option) using the
@filepath{private-key.pem} and @filepath{server-cert.pem} we've created.
@section{How do I limit the number of requests serviced at once by the Web Server?}
There is no built-in option for this, but you can easily accomplish it if you assemble your own dispatcher
by wrapping it in @scheme[call-with-semaphore]:
@schemeblock[
(define (make-limit-dispatcher num inner)
(let ([sem (make-semaphore num)])
(lambda (conn req)
(call-with-semaphore sem
(lambda () (inner conn req))))))
]
Once this function is available, rather than providing @scheme[james-gordon] as your dispatcher, you provide:
@scheme[(make-limit-dispatch 50 james-gordon)] (if you only want 50 concurrent requests.) One interesting
application of this pattern is to have a limit on certain kinds of requests. For example, you could have a
limit of 50 servlet requests, but no limit on filesystem requests.

45
collects/web-server/servlet/setup.ss
View File

@ -112,22 +112,47 @@
(define s (load/use-compiled a-path))
(cond
[(void? s)
(let* ([module-name `(file ,(path->string a-path))]
[version (dynamic-require module-name 'interface-version)])
(let* ([path-string (path->string a-path)]
[path-sym (string->symbol path-string)]
[neg-blame 'web-server]
[pos-blame path-sym]
[module-name `(file ,path-string)]
[mk-loc
(lambda (name)
(list (make-srcloc a-path #f #f #f #f)
name))]
[version
(contract (symbols 'v1 'v2 'stateless)
(dynamic-require module-name 'interface-version)
pos-blame neg-blame
(mk-loc "interface-version"))])
(case version
[(v1)
(let ([timeout (dynamic-require module-name 'timeout)]
[start (dynamic-require module-name 'start)])
(let ([timeout (contract number?
(dynamic-require module-name 'timeout)
pos-blame neg-blame
(mk-loc "timeout"))]
[start (contract (request? . -> . response?)
(dynamic-require module-name 'start)
pos-blame neg-blame
(mk-loc "start"))])
(make-v1.servlet (directory-part a-path) timeout start))]
[(v2)
(let ([start (dynamic-require module-name 'start)]
[manager (dynamic-require module-name 'manager)])
(let ([start (contract (request? . -> . response?)
(dynamic-require module-name 'start)
pos-blame neg-blame
(mk-loc "start"))]
[manager (contract manager?
(dynamic-require module-name 'manager)
pos-blame neg-blame
(mk-loc "manager"))])
(make-v2.servlet (directory-part a-path) manager start))]
[(stateless)
(let ([start (dynamic-require module-name 'start)])
(make-stateless.servlet (directory-part a-path) start))]
[else
(error 'path->servlet "unknown servlet version ~e, must be 'v1, 'v2, or 'stateless" version)]))]
(let ([start (contract (request? . -> . response?)
(dynamic-require module-name 'start)
pos-blame neg-blame
(mk-loc "start"))])
(make-stateless.servlet (directory-part a-path) start))]))]
[(response? s)
(make-v1.servlet (directory-part a-path) timeouts-default-servlet
(v0.response->v1.lambda s a-path))]

6
doc/release-notes/mred/HISTORY.txt
View File

@ -1,3 +1,9 @@
Version 4.1.3.7
image-snip% implements equal<%>
----------------------------------------------------------------------
Version 4.1.3, November 2008
Minor bug fixes

9
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,12 @@
Version 4.1.3.8
Added procedure-rename
Added extra arguments to call-with-continuation-prompt
Version 4.1.3.7
Added equal?/recur
Added extra argument to raise-syntax-error
Added equal<%> and interface* to scheme/class
Version 4.1.3.6
Memory accounting changed to bias charges to parent instead of children

8
src/mred/wxs/khead.ss
View File

@ -47,7 +47,7 @@
(let ([defined null])
(lambda (stx)
(syntax-case stx ()
[(_ name print-name super args id ...)
[(_ name print-name super (intf ...) args id ...)
(let ([nm (syntax-e (syntax name))]
[sn (syntax-e (syntax super))]
[ids (map syntax-e (syntax->list (syntax (id ...))))])
@ -78,11 +78,11 @@
(syntax
(define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
(make-primitive-class
(lambda (class prop:object preparer dispatcher)
(lambda (class prop:object preparer dispatcher more-props)
(kernel:primitive-class-prepare-struct-type!
c prop:object class preparer dispatcher))
c prop:object class preparer dispatcher more-props))
kernel:initialize-primitive-object
'print-name super 'args
'print-name super (list intf ...) 'args
'(old ...)
'(new ...)
(list

292
src/mred/wxs/wxs_snip.cxx
View File

@ -6583,6 +6583,92 @@ static Scheme_Object *bundle_symset_bitmapType(int v) {
extern void wxGetARGBPixels(wxBitmap *bm, double x, double y, int w, int h, char *s, Bool get_alpha);
static bool EqualTo(wxImageSnip* bm, wxImageSnip* bm2, void *recur);
#ifdef MZ_PRECISE_GC
END_XFORM_SKIP;
#endif
static bool OtherEqualTo(wxImageSnip* snip, wxImageSnip* snip2, void *recur)
{
int w, h;
char *s1, *s2;
wxBitmap *bm, *bm2, *mask;
bm = snip->GetSnipBitmap();
bm2 = snip2->GetSnipBitmap();
if (!bm || !bm->Ok()) return FALSE;
if (!bm2 || !bm2->Ok()) return FALSE;
if (bm->GetDepth() != bm2->GetDepth()) return FALSE;
w = bm->GetWidth();
h = bm->GetHeight();
if (w != bm2->GetWidth()) return FALSE;
if (h != bm2->GetHeight()) return FALSE;
s1 = (char *)scheme_malloc_atomic(w * h * 4);
s2 = (char *)scheme_malloc_atomic(w * h * 4);
memset(s1, 255, w * h * 4);
memset(s2, 255, w * h * 4);
wxGetARGBPixels(bm, 0, 0, w, h, s1, 0);
wxGetARGBPixels(bm2, 0, 0, w, h, s2, 0);
mask = snip->GetSnipBitmapMask();
if (mask && mask->Ok() && (mask->GetWidth() == w) && (mask->GetHeight() == h)) {
wxGetARGBPixels(mask, 0, 0, w, h, s1, 1);
}
mask = snip2->GetSnipBitmapMask();
if (mask && mask->Ok() && (mask->GetWidth() == w) && (mask->GetHeight() == h)) {
wxGetARGBPixels(mask, 0, 0, w, h, s2, 1);
}
return !memcmp(s1, s2, w * h * 4);
}
static long HashCodeOf(wxImageSnip *snip, void *recur)
{
int w, h, i;
long hk = 0;
char *s1;
wxBitmap *bm;
bm = snip->GetSnipBitmap();
if (!bm) return 0;
if (!bm->Ok()) return 0;
w = bm->GetWidth();
h = bm->GetHeight();
s1 = (char *)scheme_malloc_atomic(w * h * 4);
wxGetARGBPixels(bm, 0, 0, w, h, s1, 0);
for (i = w * h * 4; i; i -= 4) {
hk += s1[i - 4] + s1[i - 3] + s1[i - 2];
hk = (hk << 1) + hk;
}
return hk;
}
static long SecondaryHashCodeOf(wxImageSnip *snip, void *recur)
{
wxBitmap *bm;
bm = snip->GetSnipBitmap();
if (!bm) return 0;
return bm->GetWidth() + bm->GetHeight();
}
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#endif
#define UNKNOWN_OBJ void*
@ -6603,6 +6689,7 @@ static Scheme_Object *bundle_symset_bitmapType(int v) {
class os_wxImageSnip : public wxImageSnip {
public:
@ -6611,6 +6698,8 @@ class os_wxImageSnip : public wxImageSnip {
os_wxImageSnip CONSTRUCTOR_ARGS((class wxBitmap* x0, class wxBitmap* x1 = NULL));
#endif
~os_wxImageSnip();
Bool OtherEqualTo_method(class wxImageSnip* x0, UNKNOWN_OBJ x1);
Bool EqualTo_method(class wxImageSnip* x0, UNKNOWN_OBJ x1);
void SetUnmodified();
nndouble GetScrollStepOffset(nnlong x0);
nnlong FindScrollStep(double x0);
@ -6669,6 +6758,92 @@ os_wxImageSnip::~os_wxImageSnip()
objscheme_destroy(this, (Scheme_Object *) __gc_external);
}
static Scheme_Object *os_wxImageSnipOtherEqualTo(int n, Scheme_Object *p[]);
Bool os_wxImageSnip::OtherEqualTo_method(class wxImageSnip* x0, UNKNOWN_OBJ x1)
{
Scheme_Object *p[POFFSET+2] INIT_NULLED_ARRAY({ NULLED_OUT INA_comma NULLED_OUT INA_comma NULLED_OUT });
Scheme_Object *v;
Scheme_Object *method INIT_NULLED_OUT;
#ifdef MZ_PRECISE_GC
os_wxImageSnip *sElF = this;
#endif
static void *mcache = 0;
SETUP_VAR_STACK(7);
VAR_STACK_PUSH(0, method);
VAR_STACK_PUSH(1, sElF);
VAR_STACK_PUSH_ARRAY(2, p, POFFSET+2);
VAR_STACK_PUSH(5, x0);
VAR_STACK_PUSH(6, x1);
SET_VAR_STACK();
method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxImageSnip_class, "other-equal-to?", &mcache);
if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxImageSnipOtherEqualTo)) {
SET_VAR_STACK();
READY_TO_RETURN; return OtherEqualTo(SELF__, x0, x1);
} else {
p[POFFSET+0] = WITH_VAR_STACK(objscheme_bundle_wxImageSnip(x0));
p[POFFSET+1] = ((Scheme_Object *)x1);
p[0] = (Scheme_Object *) ASSELF __gc_external;
v = WITH_VAR_STACK(scheme_apply(method, POFFSET+2, p));
{
Bool resval;
resval = WITH_VAR_STACK(objscheme_unbundle_bool(v, "other-equal-to? in image-snip%"", extracting return value"));
READY_TO_RETURN;
return resval;
}
}
}
static Scheme_Object *os_wxImageSnipEqualTo(int n, Scheme_Object *p[]);
Bool os_wxImageSnip::EqualTo_method(class wxImageSnip* x0, UNKNOWN_OBJ x1)
{
Scheme_Object *p[POFFSET+2] INIT_NULLED_ARRAY({ NULLED_OUT INA_comma NULLED_OUT INA_comma NULLED_OUT });
Scheme_Object *v;
Scheme_Object *method INIT_NULLED_OUT;
#ifdef MZ_PRECISE_GC
os_wxImageSnip *sElF = this;
#endif
static void *mcache = 0;
SETUP_VAR_STACK(7);
VAR_STACK_PUSH(0, method);
VAR_STACK_PUSH(1, sElF);
VAR_STACK_PUSH_ARRAY(2, p, POFFSET+2);
VAR_STACK_PUSH(5, x0);
VAR_STACK_PUSH(6, x1);
SET_VAR_STACK();
method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxImageSnip_class, "equal-to?", &mcache);
if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxImageSnipEqualTo)) {
SET_VAR_STACK();
READY_TO_RETURN; return EqualTo(SELF__, x0, x1);
} else {
p[POFFSET+0] = WITH_VAR_STACK(objscheme_bundle_wxImageSnip(x0));
p[POFFSET+1] = ((Scheme_Object *)x1);
p[0] = (Scheme_Object *) ASSELF __gc_external;
v = WITH_VAR_STACK(scheme_apply(method, POFFSET+2, p));
{
Bool resval;
resval = WITH_VAR_STACK(objscheme_unbundle_bool(v, "equal-to? in image-snip%"", extracting return value"));
READY_TO_RETURN;
return resval;
}
}
}
static Scheme_Object *os_wxImageSnipSetUnmodified(int n, Scheme_Object *p[]);
void os_wxImageSnip::SetUnmodified()
@ -7641,6 +7816,108 @@ void os_wxImageSnip::GetExtent(class wxDC* x0, double x1, double x2, nndouble* x
}
}
static Scheme_Object *os_wxImageSnipSecondaryHashCodeOf(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
long r;
objscheme_check_valid(os_wxImageSnip_class, "equal-secondary-hash-code-of in image-snip%", n, p);
UNKNOWN_OBJ x0 INIT_NULLED_OUT;
SETUP_VAR_STACK_REMEMBERED(2);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, x0);
x0 = ((void *)p[POFFSET+0]);
r = WITH_VAR_STACK(SecondaryHashCodeOf(((wxImageSnip *)((Scheme_Class_Object *)p[0])->primdata), x0));
READY_TO_RETURN;
return scheme_make_integer(r);
}
static Scheme_Object *os_wxImageSnipHashCodeOf(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
long r;
objscheme_check_valid(os_wxImageSnip_class, "equal-hash-code-of in image-snip%", n, p);
UNKNOWN_OBJ x0 INIT_NULLED_OUT;
SETUP_VAR_STACK_REMEMBERED(2);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, x0);
x0 = ((void *)p[POFFSET+0]);
r = WITH_VAR_STACK(HashCodeOf(((wxImageSnip *)((Scheme_Class_Object *)p[0])->primdata), x0));
READY_TO_RETURN;
return scheme_make_integer(r);
}
static Scheme_Object *os_wxImageSnipOtherEqualTo(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
Bool r;
objscheme_check_valid(os_wxImageSnip_class, "other-equal-to? in image-snip%", n, p);
class wxImageSnip* x0 INIT_NULLED_OUT;
UNKNOWN_OBJ x1 INIT_NULLED_OUT;
SETUP_VAR_STACK_REMEMBERED(3);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, x0);
VAR_STACK_PUSH(2, x1);
x0 = WITH_VAR_STACK(objscheme_unbundle_wxImageSnip(p[POFFSET+0], "other-equal-to? in image-snip%", 1));
x1 = ((void *)p[POFFSET+1]);
r = WITH_VAR_STACK(OtherEqualTo(((wxImageSnip *)((Scheme_Class_Object *)p[0])->primdata), x0, x1));
READY_TO_RETURN;
return (r ? scheme_true : scheme_false);
}
static Scheme_Object *os_wxImageSnipEqualTo(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
Bool r;
objscheme_check_valid(os_wxImageSnip_class, "equal-to? in image-snip%", n, p);
class wxImageSnip* x0 INIT_NULLED_OUT;
UNKNOWN_OBJ x1 INIT_NULLED_OUT;
SETUP_VAR_STACK_REMEMBERED(3);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, x0);
VAR_STACK_PUSH(2, x1);
x0 = WITH_VAR_STACK(objscheme_unbundle_wxImageSnip(p[POFFSET+0], "equal-to? in image-snip%", 1));
x1 = ((void *)p[POFFSET+1]);
r = WITH_VAR_STACK(EqualTo(((wxImageSnip *)((Scheme_Class_Object *)p[0])->primdata), x0, x1));
READY_TO_RETURN;
return (r ? scheme_true : scheme_false);
}
static Scheme_Object *os_wxImageSnipSetOffset(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
@ -8707,8 +8984,12 @@ void objscheme_setup_wxImageSnip(Scheme_Env *env)
wxREGGLOB(os_wxImageSnip_class);
os_wxImageSnip_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "image-snip%", "snip%", (Scheme_Method_Prim *)os_wxImageSnip_ConstructScheme, 31));
os_wxImageSnip_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "image-snip%", "snip%", (Scheme_Method_Prim *)os_wxImageSnip_ConstructScheme, 35));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "equal-secondary-hash-code-of" " method", (Scheme_Method_Prim *)os_wxImageSnipSecondaryHashCodeOf, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "equal-hash-code-of" " method", (Scheme_Method_Prim *)os_wxImageSnipHashCodeOf, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "other-equal-to?" " method", (Scheme_Method_Prim *)os_wxImageSnipOtherEqualTo, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "equal-to?" " method", (Scheme_Method_Prim *)os_wxImageSnipEqualTo, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "set-offset" " method", (Scheme_Method_Prim *)os_wxImageSnipSetOffset, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "get-bitmap-mask" " method", (Scheme_Method_Prim *)os_wxImageSnipGetSnipBitmapMask, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxImageSnip_class, "get-bitmap" " method", (Scheme_Method_Prim *)os_wxImageSnipGetSnipBitmap, 0, 0));
@ -8805,6 +9086,15 @@ class wxImageSnip *objscheme_unbundle_wxImageSnip(Scheme_Object *obj, const char
}
static bool EqualTo(wxImageSnip* bm, wxImageSnip* bm2, void *recur)
{
/* Might redirect to Scheme.
We're relying on the cast succeeding because the method is
not virtual, but I doubt that this is guaranteed to work by the C++
spec if wxImageSnip is instantiated instead of os_wxImageSnip */
return ((os_wxImageSnip *)bm2)->OtherEqualTo_method(bm, recur);
}

4
src/mred/wxs/wxs_snip.h
View File

@ -151,6 +151,8 @@ void objscheme_setup_wxTabSnip(Scheme_Env *env);
int objscheme_istype_wxTabSnip(Scheme_Object *obj, const char *stop, int nullOK);
Scheme_Object *objscheme_bundle_wxTabSnip(class wxTabSnip *realobj);
class wxTabSnip *objscheme_unbundle_wxTabSnip(Scheme_Object *obj, const char *where, int nullOK);
extern Scheme_Object *objscheme_bundle_wxImageSnip(class wxImageSnip *);
extern Scheme_Object *objscheme_bundle_wxImageSnip(class wxImageSnip *);
extern Scheme_Object *objscheme_bundle_wxSnipAdmin(class wxSnipAdmin *);
extern Scheme_Object *objscheme_bundle_wxMediaStreamOut(class wxMediaStreamOut *);
extern Scheme_Object *objscheme_bundle_wxSnip(class wxSnip *);
@ -172,6 +174,8 @@ extern class wxSnip *objscheme_unbundle_wxSnip(Scheme_Object *, const char *, in
extern Scheme_Object *objscheme_bundle_wxDC(class wxDC *);
extern Scheme_Object *objscheme_bundle_wxDC(class wxDC *);
extern Scheme_Object *objscheme_bundle_wxDC(class wxDC *);
extern class wxImageSnip *objscheme_unbundle_wxImageSnip(Scheme_Object *, const char *, int);
extern class wxImageSnip *objscheme_unbundle_wxImageSnip(Scheme_Object *, const char *, int);
extern Scheme_Object *objscheme_bundle_wxBitmap(class wxBitmap *);
extern Scheme_Object *objscheme_bundle_wxBitmap(class wxBitmap *);
extern class wxBitmap *objscheme_unbundle_wxBitmap(Scheme_Object *, const char *, int);

103
src/mred/wxs/wxs_snip.xc
View File

@ -88,8 +88,97 @@
@INCLUDE wxs_bmt.xci
extern void wxGetARGBPixels(wxBitmap *bm, double x, double y, int w, int h, char *s, Bool get_alpha);
static bool EqualTo(wxImageSnip* bm, wxImageSnip* bm2, void *recur);
#ifdef MZ_PRECISE_GC
END_XFORM_SKIP;
#endif
static bool OtherEqualTo(wxImageSnip* snip, wxImageSnip* snip2, void *recur)
{
int w, h;
char *s1, *s2;
wxBitmap *bm, *bm2, *mask;
bm = snip->GetSnipBitmap();
bm2 = snip2->GetSnipBitmap();
if (!bm || !bm->Ok()) return FALSE;
if (!bm2 || !bm2->Ok()) return FALSE;
if (bm->GetDepth() != bm2->GetDepth()) return FALSE;
w = bm->GetWidth();
h = bm->GetHeight();
if (w != bm2->GetWidth()) return FALSE;
if (h != bm2->GetHeight()) return FALSE;
s1 = (char *)scheme_malloc_atomic(w * h * 4);
s2 = (char *)scheme_malloc_atomic(w * h * 4);
memset(s1, 255, w * h * 4);
memset(s2, 255, w * h * 4);
wxGetARGBPixels(bm, 0, 0, w, h, s1, 0);
wxGetARGBPixels(bm2, 0, 0, w, h, s2, 0);
mask = snip->GetSnipBitmapMask();
if (mask && mask->Ok() && (mask->GetWidth() == w) && (mask->GetHeight() == h)) {
wxGetARGBPixels(mask, 0, 0, w, h, s1, 1);
}
mask = snip2->GetSnipBitmapMask();
if (mask && mask->Ok() && (mask->GetWidth() == w) && (mask->GetHeight() == h)) {
wxGetARGBPixels(mask, 0, 0, w, h, s2, 1);
}
return !memcmp(s1, s2, w * h * 4);
}
static long HashCodeOf(wxImageSnip *snip, void *recur)
{
int w, h, i;
long hk = 0;
char *s1;
wxBitmap *bm;
bm = snip->GetSnipBitmap();
if (!bm) return 0;
if (!bm->Ok()) return 0;
w = bm->GetWidth();
h = bm->GetHeight();
s1 = (char *)scheme_malloc_atomic(w * h * 4);
wxGetARGBPixels(bm, 0, 0, w, h, s1, 0);
for (i = w * h * 4; i; i -= 4) {
hk += s1[i - 4] + s1[i - 3] + s1[i - 2];
hk = (hk << 1) + hk;
}
return hk;
}
static long SecondaryHashCodeOf(wxImageSnip *snip, void *recur)
{
wxBitmap *bm;
bm = snip->GetSnipBitmap();
if (!bm) return 0;
return bm->GetWidth() + bm->GetHeight();
}
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#endif
#define UNKNOWN_OBJ void*
@MACRO bundleAny = ((Scheme_Object *){x})
@MACRO unbundleAny = ((void *){x})
@CLASSBASE wxImageSnip "image-snip":"snip" / nofnl
@IMPLEMENTS equal<%>
@CREATOR (nxpathname=NULL,SYM[bitmapType]=0,bool=FALSE,bool=TRUE); : : //USEALLFUEL[x0] <> filename
@CREATOR (wxBitmap!,wxBitmap^=NULL) : : /CheckBW[1.METHODNAME("image-snip%","initialization")]|CHECKOK[0.METHODNAME("image-snip%","initialization")]|CHECKOK[1.METHODNAME("image-snip%","initialization")]|CheckSizes[0.1.METHODNAME("image-snip%","initialization")] <> bitmap
@ -111,8 +200,22 @@
@ "set-offset" : void SetOffset(double, double);
@ M "equal-to?" : bool EqualTo(wxImageSnip^,UNKNOWN_OBJ/bundleAny/unbundleAny////push);
@ M "other-equal-to?" : bool OtherEqualTo(wxImageSnip^,UNKNOWN_OBJ/bundleAny/unbundleAny////push);
@ m "equal-hash-code-of" : long HashCodeOf(UNKNOWN_OBJ/bundleAny/unbundleAny////push);
@ m "equal-secondary-hash-code-of" : long SecondaryHashCodeOf(UNKNOWN_OBJ/bundleAny/unbundleAny////push);
@END
static bool EqualTo(wxImageSnip* bm, wxImageSnip* bm2, void *recur)
{
/* Might redirect to Scheme.
We're relying on the cast succeeding because the method is
not virtual, but I doubt that this is guaranteed to work by the C++
spec if wxImageSnip is instantiated instead of os_wxImageSnip */
return ((os_wxImageSnip *)bm2)->OtherEqualTo_method(bm, recur);
}
@CLASSBASE wxMediaSnip "editor-snip" : "snip" / nofnl
@CREATOR (wxMediaBuffer^=NULL,bool=TRUE,nnint=wxMSNIPBOX_XMARGIN,nnint=wxMSNIPBOX_YMARGIN,nnint=wxMSNIPBOX_XMARGIN,nnint=wxMSNIPBOX_YMARGIN,nnint=wxMSNIPBOX_XINSET,nnint=wxMSNIPBOX_YINSET,nnint=wxMSNIPBOX_XINSET,nnint=wxMSNIPBOX_YINSET,nnfs[none]=-1,nnfs[none]=-1,nnfs[none]=-1,nnfs[none]=-1);

45
src/mzscheme/src/bool.c
View File

@ -48,12 +48,14 @@ static Scheme_Object *boolean_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]);
typedef struct Equal_Info {
long depth; /* always odd */
long car_depth; /* always odd */
long depth; /* always odd, so it looks like a fixnum */
long car_depth; /* always odd => fixnum */
Scheme_Hash_Table *ht;
Scheme_Object *recur;
Scheme_Object *next, *next_next;
} Equal_Info;
static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
@ -95,6 +97,10 @@ void scheme_init_bool (Scheme_Env *env)
scheme_equal_prim = scheme_make_prim_w_arity(equal_prim, "equal?", 2, 2);
scheme_add_global_constant("equal?", scheme_equal_prim, env);
scheme_add_global_constant("equal?/recur",
scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3),
env);
}
static Scheme_Object *
@ -130,6 +136,25 @@ equal_prim (int argc, Scheme_Object *argv[])
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next = NULL;
eql.next_next = NULL;
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}
static Scheme_Object *
equalish_prim (int argc, Scheme_Object *argv[])
{
Equal_Info eql;
scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv);
eql.depth = 1;
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next = NULL;
eql.next_next = argv[2];
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}
@ -222,6 +247,8 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next_next = NULL;
eql.next = NULL;
return is_equal(obj1, obj2, &eql);
}
@ -252,7 +279,8 @@ static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht)
static int union_check(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
if (eql->depth < 50) {
eql->depth += 2;
if (!eql->next_next)
eql->depth += 2;
return 0;
} else {
Scheme_Hash_Table *ht = eql->ht;
@ -324,6 +352,17 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
static int equal_counter = EQUAL_COUNT_START;
top:
if (eql->next_next) {
if (eql->next) {
Scheme_Object *a[2];
a[0] = obj1;
a[1] = obj2;
obj1 = _scheme_apply(eql->next, 2, a);
return SCHEME_TRUEP(obj1);
}
eql->next = eql->next_next;
}
if (scheme_eqv(obj1, obj2))
return 1;
else if (NOT_SAME_TYPE(SCHEME_TYPE(obj1), SCHEME_TYPE(obj2))) {

897
src/mzscheme/src/cstartup.inc
View File

@ -1,13 +1,13 @@
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,54,50,0,0,0,1,0,0,3,0,12,0,
16,0,23,0,26,0,31,0,38,0,43,0,48,0,55,0,68,0,72,0,78,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,56,50,0,0,0,1,0,0,3,0,12,0,
17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78,
0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165,
1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3,
132,4,34,5,84,5,107,5,186,5,0,0,132,7,0,0,29,11,11,68,104,
101,114,101,45,115,116,120,63,108,101,116,66,100,101,102,105,110,101,62,111,114,
64,108,101,116,42,66,117,110,108,101,115,115,64,99,111,110,100,64,119,104,101,
110,66,108,101,116,114,101,99,72,112,97,114,97,109,101,116,101,114,105,122,101,
101,114,101,45,115,116,120,64,99,111,110,100,62,111,114,66,108,101,116,114,101,
99,72,112,97,114,97,109,101,116,101,114,105,122,101,66,117,110,108,101,115,115,
63,108,101,116,66,100,101,102,105,110,101,64,119,104,101,110,64,108,101,116,42,
63,97,110,100,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110,
101,108,11,29,94,2,13,68,35,37,112,97,114,97,109,122,11,62,105,102,65,
98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,
@ -15,66 +15,66 @@
98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98,
10,35,11,8,180,243,94,159,2,15,35,35,159,2,14,35,35,16,20,2,3,
2,1,2,4,2,1,2,10,2,1,2,5,2,1,2,6,2,1,2,7,2,
1,2,8,2,1,2,9,2,1,2,11,2,1,2,12,2,1,97,36,11,8,
2,1,2,5,2,1,2,6,2,1,2,7,2,1,2,8,2,1,2,9,2,
1,2,10,2,1,2,4,2,1,2,11,2,1,2,12,2,1,97,36,11,8,
180,243,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,2,2,1,2,
2,97,10,11,11,8,180,243,16,0,97,10,37,11,8,180,243,16,0,13,16,
4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31,8,30,
8,29,8,28,8,27,93,8,224,251,60,0,0,95,9,8,224,251,60,0,0,
2,1,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,
2,16,248,22,89,23,200,2,12,249,22,64,2,17,248,22,91,23,202,1,27,
248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,2,16,248,
22,89,23,200,2,249,22,64,2,17,248,22,91,23,202,1,12,27,248,22,66,
248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,28,
248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,38,35,
251,22,74,2,16,248,22,65,23,200,2,249,22,64,2,12,248,22,66,23,202,
2,1,27,248,22,134,4,23,196,1,249,22,191,3,80,158,38,35,251,22,75,
2,16,248,22,90,23,200,2,12,249,22,65,2,17,248,22,92,23,202,1,27,
248,22,134,4,23,196,1,249,22,191,3,80,158,38,35,251,22,75,2,16,248,
22,90,23,200,2,249,22,65,2,17,248,22,92,23,202,1,12,27,248,22,67,
248,22,134,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35,36,28,
248,22,73,248,22,67,23,195,2,248,22,66,193,249,22,191,3,80,158,38,35,
251,22,75,2,16,248,22,66,23,200,2,249,22,65,2,12,248,22,67,23,202,
1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
2,18,3,1,7,101,110,118,57,55,57,51,16,4,11,11,2,19,3,1,7,
101,110,118,57,55,57,52,93,8,224,252,60,0,0,95,9,8,224,252,60,0,
0,2,1,27,248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,
20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,
22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,74,248,22,74,
2,21,248,22,65,23,202,2,251,22,74,2,16,2,21,2,21,249,22,64,2,
5,248,22,66,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8,
0,2,1,27,248,22,67,248,22,134,4,23,197,1,28,248,22,73,23,194,2,
20,15,159,36,35,36,28,248,22,73,248,22,67,23,195,2,248,22,66,193,249,
22,191,3,80,158,38,35,250,22,75,2,20,248,22,75,249,22,75,248,22,75,
2,21,248,22,66,23,202,2,251,22,75,2,16,2,21,2,21,249,22,65,2,
4,248,22,67,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8,
27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,54,16,4,11,11,
2,19,3,1,7,101,110,118,57,55,57,55,93,8,224,253,60,0,0,95,9,
8,224,253,60,0,0,2,1,248,22,133,4,193,27,248,22,133,4,194,249,22,
64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,
197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,248,22,65,
8,224,253,60,0,0,2,1,248,22,134,4,193,27,248,22,134,4,194,249,22,
65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,134,4,23,
197,1,249,22,191,3,80,158,38,35,28,248,22,53,248,22,128,4,248,22,66,
23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39,248,22,
133,4,248,22,89,23,200,2,250,22,74,2,22,248,22,74,249,22,74,248,22,
74,248,22,65,23,204,2,250,22,75,2,23,249,22,2,22,65,23,204,2,248,
22,91,23,206,2,249,22,64,248,22,65,23,202,1,249,22,2,22,89,23,200,
1,250,22,75,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40,
248,22,133,4,248,22,65,201,248,22,66,198,27,248,22,133,4,194,249,22,64,
248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,197,
1,249,22,190,3,80,158,38,35,250,22,75,2,22,249,22,2,32,0,89,162,
8,44,36,46,9,222,33,42,248,22,133,4,248,22,65,201,248,22,66,198,27,
248,22,66,248,22,133,4,196,27,248,22,133,4,248,22,65,195,249,22,190,3,
80,158,39,35,28,248,22,72,195,250,22,75,2,20,9,248,22,66,199,250,22,
74,2,3,248,22,74,248,22,65,199,250,22,75,2,6,248,22,66,201,248,22,
66,202,27,248,22,66,248,22,133,4,23,197,1,27,249,22,1,22,78,249,22,
2,22,133,4,248,22,133,4,248,22,65,199,249,22,190,3,80,158,39,35,251,
22,74,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,
45,109,97,114,107,2,24,250,22,75,1,23,101,120,116,101,110,100,45,112,97,
134,4,248,22,90,23,200,2,250,22,75,2,22,248,22,75,249,22,75,248,22,
75,248,22,66,23,204,2,250,22,76,2,23,249,22,2,22,66,23,204,2,248,
22,92,23,206,2,249,22,65,248,22,66,23,202,1,249,22,2,22,90,23,200,
1,250,22,76,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40,
248,22,134,4,248,22,66,201,248,22,67,198,27,248,22,134,4,194,249,22,65,
248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,134,4,23,197,
1,249,22,191,3,80,158,38,35,250,22,76,2,22,249,22,2,32,0,89,162,
8,44,36,46,9,222,33,42,248,22,134,4,248,22,66,201,248,22,67,198,27,
248,22,67,248,22,134,4,196,27,248,22,134,4,248,22,66,195,249,22,191,3,
80,158,39,35,28,248,22,73,195,250,22,76,2,20,9,248,22,67,199,250,22,
75,2,8,248,22,75,248,22,66,199,250,22,76,2,11,248,22,67,201,248,22,
67,202,27,248,22,67,248,22,134,4,23,197,1,27,249,22,1,22,79,249,22,
2,22,134,4,248,22,134,4,248,22,66,199,249,22,191,3,80,158,39,35,251,
22,75,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,
45,109,97,114,107,2,24,250,22,76,1,23,101,120,116,101,110,100,45,112,97,
114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99,111,110,
116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102,105,
114,115,116,11,2,24,201,250,22,75,2,20,9,248,22,66,203,27,248,22,66,
248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,249,
22,190,3,80,158,38,35,27,248,22,133,4,248,22,65,23,198,2,28,249,22,
162,8,62,61,62,248,22,191,3,248,22,89,23,197,2,250,22,74,2,20,248,
22,74,249,22,74,21,93,2,25,248,22,65,199,250,22,75,2,8,249,22,74,
2,25,249,22,74,248,22,98,203,2,25,248,22,66,202,251,22,74,2,16,28,
249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,101,10,248,
22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,22,64,2,
8,248,22,66,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
114,115,116,11,2,24,201,250,22,76,2,20,9,248,22,67,203,27,248,22,67,
248,22,134,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35,36,249,
22,191,3,80,158,38,35,27,248,22,134,4,248,22,66,23,198,2,28,249,22,
163,8,62,61,62,248,22,128,4,248,22,90,23,197,2,250,22,75,2,20,248,
22,75,249,22,75,21,93,2,25,248,22,66,199,250,22,76,2,3,249,22,75,
2,25,249,22,75,248,22,99,203,2,25,248,22,67,202,251,22,75,2,16,28,
249,22,163,8,248,22,128,4,248,22,66,23,201,2,64,101,108,115,101,10,248,
22,66,23,198,2,250,22,76,2,20,9,248,22,67,23,201,1,249,22,65,2,
3,248,22,67,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,7,101,110,118,57,56,49,57,16,4,11,11,2,19,3,1,
7,101,110,118,57,56,50,48,93,8,224,254,60,0,0,18,16,2,158,94,10,
64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,1,27,248,22,66,
248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,
248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,248,22,89,198,27,
248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,197,250,
22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,159,35,16,1,11,
64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,1,27,248,22,67,
248,22,134,4,196,249,22,191,3,80,158,38,35,28,248,22,53,248,22,128,4,
248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,199,248,22,90,198,27,
248,22,128,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,197,250,
22,76,2,23,248,22,67,199,248,22,67,202,159,35,20,103,159,35,16,1,11,
16,0,83,158,41,20,100,143,69,35,37,109,105,110,45,115,116,120,2,1,11,
10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1,2,
2,36,16,0,35,16,0,35,11,11,38,35,11,11,16,10,2,3,2,4,2,
@ -84,29 +84,29 @@
11,11,16,0,16,0,16,0,35,35,16,11,16,5,2,2,20,15,159,35,35,
35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,7,89,162,8,44,
36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0,11,16,5,
2,9,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35,16,1,2,
2,10,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35,16,1,2,
2,16,0,11,16,5,2,12,89,162,8,44,36,52,9,223,0,33,35,35,20,
103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,5,89,162,8,44,36,
103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,4,89,162,8,44,36,
55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33,38,11,16,
5,2,3,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159,35,16,1,
2,2,16,0,11,16,5,2,10,89,162,8,44,36,52,9,223,0,33,43,35,
20,103,159,35,16,1,2,2,16,0,11,16,5,2,6,89,162,8,44,36,53,
9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,11,
5,2,8,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159,35,16,1,
2,2,16,0,11,16,5,2,5,89,162,8,44,36,52,9,223,0,33,43,35,
20,103,159,35,16,1,2,2,16,0,11,16,5,2,11,89,162,8,44,36,53,
9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,6,
89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1,2,2,16,
0,11,16,5,2,8,89,162,8,44,36,57,9,223,0,33,46,35,20,103,159,
35,16,1,2,2,16,1,33,48,11,16,5,2,4,89,162,8,44,36,53,9,
0,11,16,5,2,3,89,162,8,44,36,57,9,223,0,33,46,35,20,103,159,
35,16,1,2,2,16,1,33,48,11,16,5,2,9,89,162,8,44,36,53,9,
223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0,94,2,14,
2,15,93,2,14,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2045);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,54,59,0,0,0,1,0,0,13,0,18,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,56,59,0,0,0,1,0,0,13,0,18,0,
35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226,
0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1,
199,1,223,1,6,2,8,2,65,2,155,3,196,3,30,5,134,5,238,5,99,
6,113,6,147,6,163,6,13,8,27,8,190,8,191,9,191,10,198,10,205,10,
212,10,87,11,100,11,55,12,157,12,170,12,192,12,144,13,48,14,119,15,127,
15,135,15,161,15,15,16,0,0,3,19,0,0,72,112,97,116,104,45,115,116,
199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100,
6,114,6,148,6,164,6,14,8,28,8,191,8,192,9,192,10,199,10,206,10,
213,10,88,11,101,11,56,12,158,12,171,12,193,12,145,13,49,14,121,15,129,
15,137,15,163,15,18,16,0,0,6,19,0,0,72,112,97,116,104,45,115,116,
114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,108,45,99,97,115,
101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,108,112,97,116,104,
77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,111,110,75,99,111,
@ -132,217 +132,217 @@
116,101,32,115,116,114,105,110,103,6,36,36,99,97,110,110,111,116,32,97,100,
100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32,
112,97,116,104,58,32,5,0,27,20,14,159,80,158,36,50,250,80,158,39,51,
249,22,27,11,80,158,41,50,22,179,12,10,248,22,155,5,23,196,2,28,248,
22,152,6,23,194,2,12,87,94,248,22,165,8,23,194,1,248,80,159,37,53,
36,195,28,248,22,72,23,195,2,9,27,248,22,65,23,196,2,27,28,248,22,
160,13,23,195,2,23,194,1,28,248,22,159,13,23,195,2,249,22,161,13,23,
196,1,250,80,158,42,48,248,22,175,13,2,19,11,10,250,80,158,40,48,248,
22,175,13,2,19,23,197,1,10,28,23,193,2,249,22,64,248,22,163,13,249,
22,161,13,23,198,1,247,22,176,13,27,248,22,66,23,200,1,28,248,22,72,
23,194,2,9,27,248,22,65,23,195,2,27,28,248,22,160,13,23,195,2,23,
194,1,28,248,22,159,13,23,195,2,249,22,161,13,23,196,1,250,80,158,47,
48,248,22,175,13,2,19,11,10,250,80,158,45,48,248,22,175,13,2,19,23,
197,1,10,28,23,193,2,249,22,64,248,22,163,13,249,22,161,13,23,198,1,
247,22,176,13,248,80,159,45,52,36,248,22,66,23,199,1,87,94,23,193,1,
248,80,159,43,52,36,248,22,66,23,197,1,87,94,23,193,1,27,248,22,66,
23,198,1,28,248,22,72,23,194,2,9,27,248,22,65,23,195,2,27,28,248,
22,160,13,23,195,2,23,194,1,28,248,22,159,13,23,195,2,249,22,161,13,
23,196,1,250,80,158,45,48,248,22,175,13,2,19,11,10,250,80,158,43,48,
248,22,175,13,2,19,23,197,1,10,28,23,193,2,249,22,64,248,22,163,13,
249,22,161,13,23,198,1,247,22,176,13,248,80,159,43,52,36,248,22,66,23,
199,1,248,80,159,41,52,36,248,22,66,196,27,248,22,136,13,23,195,2,28,
23,193,2,192,87,94,23,193,1,28,248,22,157,6,23,195,2,27,248,22,158,
13,195,28,192,192,248,22,159,13,195,11,87,94,28,28,248,22,137,13,23,195,
2,10,27,248,22,136,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,
248,22,157,6,23,196,2,27,248,22,158,13,23,197,2,28,23,193,2,192,87,
94,23,193,1,248,22,159,13,23,197,2,11,12,250,22,129,9,76,110,111,114,
249,22,27,11,80,158,41,50,22,181,12,10,248,22,156,5,23,196,2,28,248,
22,153,6,23,194,2,12,87,94,248,22,167,8,23,194,1,248,80,159,37,53,
36,195,28,248,22,73,23,195,2,9,27,248,22,66,23,196,2,27,28,248,22,
162,13,23,195,2,23,194,1,28,248,22,161,13,23,195,2,249,22,163,13,23,
196,1,250,80,158,42,48,248,22,177,13,2,19,11,10,250,80,158,40,48,248,
22,177,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,165,13,249,
22,163,13,23,198,1,247,22,178,13,27,248,22,67,23,200,1,28,248,22,73,
23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,162,13,23,195,2,23,
194,1,28,248,22,161,13,23,195,2,249,22,163,13,23,196,1,250,80,158,47,
48,248,22,177,13,2,19,11,10,250,80,158,45,48,248,22,177,13,2,19,23,
197,1,10,28,23,193,2,249,22,65,248,22,165,13,249,22,163,13,23,198,1,
247,22,178,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1,
248,80,159,43,52,36,248,22,67,23,197,1,87,94,23,193,1,27,248,22,67,
23,198,1,28,248,22,73,23,194,2,9,27,248,22,66,23,195,2,27,28,248,
22,162,13,23,195,2,23,194,1,28,248,22,161,13,23,195,2,249,22,163,13,
23,196,1,250,80,158,45,48,248,22,177,13,2,19,11,10,250,80,158,43,48,
248,22,177,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,165,13,
249,22,163,13,23,198,1,247,22,178,13,248,80,159,43,52,36,248,22,67,23,
199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,138,13,23,195,2,28,
23,193,2,192,87,94,23,193,1,28,248,22,158,6,23,195,2,27,248,22,160,
13,195,28,192,192,248,22,161,13,195,11,87,94,28,28,248,22,139,13,23,195,
2,10,27,248,22,138,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,
248,22,158,6,23,196,2,27,248,22,160,13,23,197,2,28,23,193,2,192,87,
94,23,193,1,248,22,161,13,23,197,2,11,12,250,22,131,9,76,110,111,114,
109,97,108,45,112,97,116,104,45,99,97,115,101,6,42,42,112,97,116,104,32,
40,102,111,114,32,97,110,121,32,115,121,115,116,101,109,41,32,111,114,32,118,
97,108,105,100,45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,28,28,
248,22,137,13,23,195,2,249,22,162,8,248,22,138,13,23,197,2,2,20,249,
22,162,8,247,22,176,7,2,20,27,28,248,22,157,6,23,196,2,23,195,2,
248,22,166,7,248,22,141,13,23,197,2,28,249,22,188,13,0,21,35,114,120,
248,22,139,13,23,195,2,249,22,163,8,248,22,140,13,23,197,2,2,20,249,
22,163,8,247,22,177,7,2,20,27,28,248,22,158,6,23,196,2,23,195,2,
248,22,167,7,248,22,143,13,23,197,2,28,249,22,190,13,0,21,35,114,120,
34,94,91,92,92,93,91,92,92,93,91,63,93,91,92,92,93,34,23,195,2,
28,248,22,157,6,195,248,22,144,13,195,194,27,248,22,132,7,23,195,1,249,
22,145,13,248,22,169,7,250,22,130,14,0,6,35,114,120,34,47,34,28,249,
22,188,13,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,
92,92,93,42,36,34,23,201,2,23,199,1,250,22,130,14,0,19,35,114,120,
28,248,22,158,6,195,248,22,146,13,195,194,27,248,22,133,7,23,195,1,249,
22,147,13,248,22,170,7,250,22,132,14,0,6,35,114,120,34,47,34,28,249,
22,190,13,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,
92,92,93,42,36,34,23,201,2,23,199,1,250,22,132,14,0,19,35,114,120,
34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,23,202,1,6,2,
2,92,49,80,158,43,36,2,20,28,248,22,157,6,194,248,22,144,13,194,193,
87,94,28,27,248,22,136,13,23,196,2,28,23,193,2,192,87,94,23,193,1,
28,248,22,157,6,23,196,2,27,248,22,158,13,23,197,2,28,23,193,2,192,
87,94,23,193,1,248,22,159,13,23,197,2,11,12,250,22,129,9,23,196,2,
2,21,23,197,2,28,248,22,158,13,23,195,2,12,248,22,155,11,249,22,164,
10,248,22,186,6,250,22,141,7,2,22,23,200,1,23,201,1,247,22,23,87,
94,28,27,248,22,136,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,
248,22,157,6,23,196,2,27,248,22,158,13,23,197,2,28,23,193,2,192,87,
94,23,193,1,248,22,159,13,23,197,2,11,12,250,22,129,9,23,196,2,2,
21,23,197,2,28,248,22,158,13,23,195,2,12,248,22,155,11,249,22,164,10,
248,22,186,6,250,22,141,7,2,22,23,200,1,23,201,1,247,22,23,87,94,
87,94,28,27,248,22,136,13,23,196,2,28,23,193,2,192,87,94,23,193,1,
28,248,22,157,6,23,196,2,27,248,22,158,13,23,197,2,28,23,193,2,192,
87,94,23,193,1,248,22,159,13,23,197,2,11,12,250,22,129,9,195,2,21,
23,197,2,28,248,22,158,13,23,195,2,12,248,22,155,11,249,22,164,10,248,
22,186,6,250,22,141,7,2,22,199,23,201,1,247,22,23,249,22,3,89,162,
8,44,36,49,9,223,2,33,33,196,248,22,155,11,249,22,130,11,23,196,1,
247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41,36,
2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162,43,
41,58,65,99,108,111,111,112,222,33,38,28,248,22,72,23,199,2,87,94,23,
198,1,248,23,196,1,251,22,141,7,2,23,23,199,1,28,248,22,72,23,203,
2,87,94,23,202,1,23,201,1,250,22,1,22,154,13,23,204,1,23,205,1,
23,198,1,27,249,22,154,13,248,22,65,23,202,2,23,199,2,28,248,22,149,
13,23,194,2,27,250,22,1,22,154,13,23,197,1,23,202,2,28,248,22,149,
13,23,194,2,192,87,94,23,193,1,27,248,22,66,23,202,1,28,248,22,72,
23,194,2,87,94,23,193,1,248,23,199,1,251,22,141,7,2,23,23,202,1,
28,248,22,72,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,154,13,
23,207,1,23,208,1,23,201,1,27,249,22,154,13,248,22,65,23,197,2,23,
202,2,28,248,22,149,13,23,194,2,27,250,22,1,22,154,13,23,197,1,204,
28,248,22,149,13,193,192,253,2,37,203,204,205,206,23,15,248,22,66,201,253,
2,37,202,203,204,205,206,248,22,66,200,87,94,23,193,1,27,248,22,66,23,
201,1,28,248,22,72,23,194,2,87,94,23,193,1,248,23,198,1,251,22,141,
7,2,23,23,201,1,28,248,22,72,23,205,2,87,94,23,204,1,23,203,1,
250,22,1,22,154,13,23,206,1,23,207,1,23,200,1,27,249,22,154,13,248,
22,65,23,197,2,23,201,2,28,248,22,149,13,23,194,2,27,250,22,1,22,
154,13,23,197,1,203,28,248,22,149,13,193,192,253,2,37,202,203,204,205,206,
248,22,66,201,253,2,37,201,202,203,204,205,248,22,66,200,27,247,22,177,13,
253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,137,13,23,194,2,10,
27,248,22,136,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248,22,
157,6,23,195,2,27,248,22,158,13,23,196,2,28,23,193,2,192,87,94,23,
193,1,248,22,159,13,23,196,2,11,12,252,22,129,9,23,200,2,2,24,35,
23,198,2,23,199,2,28,28,248,22,157,6,23,195,2,10,248,22,145,7,23,
195,2,87,94,23,194,1,12,252,22,129,9,23,200,2,2,25,36,23,198,2,
23,199,1,91,159,38,11,90,161,38,35,11,248,22,157,13,23,197,2,87,94,
23,195,1,87,94,28,192,12,250,22,130,9,23,201,1,2,26,23,199,1,249,
22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,137,13,
23,196,2,10,27,248,22,136,13,23,197,2,28,23,193,2,192,87,94,23,193,
1,28,248,22,157,6,23,197,2,27,248,22,158,13,23,198,2,28,23,193,2,
192,87,94,23,193,1,248,22,159,13,23,198,2,11,12,252,22,129,9,2,9,
2,24,35,23,200,2,23,201,2,28,28,248,22,157,6,23,197,2,10,248,22,
145,7,23,197,2,12,252,22,129,9,2,9,2,25,36,23,200,2,23,201,2,
91,159,38,11,90,161,38,35,11,248,22,157,13,23,199,2,87,94,23,195,1,
87,94,28,192,12,250,22,130,9,2,9,2,26,23,201,2,249,22,7,194,195,
27,249,22,146,13,250,22,129,14,0,18,35,114,120,35,34,40,91,46,93,91,
94,46,93,42,124,41,36,34,248,22,142,13,23,201,1,28,248,22,157,6,23,
203,2,249,22,169,7,23,204,1,8,63,23,202,1,28,248,22,137,13,23,199,
2,248,22,138,13,23,199,1,87,94,23,198,1,247,22,139,13,28,248,22,136,
13,194,249,22,154,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95,28,
28,248,22,137,13,23,196,2,10,27,248,22,136,13,23,197,2,28,23,193,2,
192,87,94,23,193,1,28,248,22,157,6,23,197,2,27,248,22,158,13,23,198,
2,28,23,193,2,192,87,94,23,193,1,248,22,159,13,23,198,2,11,12,252,
22,129,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,157,6,23,
197,2,10,248,22,145,7,23,197,2,12,252,22,129,9,2,10,2,25,36,23,
200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,157,13,23,199,2,
87,94,23,195,1,87,94,28,192,12,250,22,130,9,2,10,2,26,23,201,2,
249,22,7,194,195,27,249,22,146,13,249,22,155,7,250,22,130,14,0,9,35,
114,120,35,34,91,46,93,34,248,22,142,13,23,203,1,6,1,1,95,28,248,
22,157,6,23,202,2,249,22,169,7,23,203,1,8,63,23,201,1,28,248,22,
137,13,23,199,2,248,22,138,13,23,199,1,87,94,23,198,1,247,22,139,13,
28,248,22,136,13,194,249,22,154,13,195,194,192,249,247,22,188,4,194,11,249,
80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,179,13,249,80,158,
38,47,28,23,195,2,27,248,22,174,7,6,11,11,80,76,84,67,79,76,76,
69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,196,1,250,22,154,
13,248,22,175,13,69,97,100,100,111,110,45,100,105,114,247,22,172,7,6,8,
8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,36,250,22,78,23,
203,1,248,22,74,248,22,175,13,72,99,111,108,108,101,99,116,115,45,100,105,
114,23,204,1,28,23,194,2,249,22,64,23,196,1,23,195,1,192,32,47,89,
162,8,44,38,54,2,18,222,33,48,27,249,22,186,13,23,197,2,23,198,2,
28,23,193,2,87,94,23,196,1,27,248,22,89,23,195,2,27,27,248,22,98,
23,197,1,27,249,22,186,13,23,201,2,23,196,2,28,23,193,2,87,94,23,
194,1,27,248,22,89,23,195,2,27,250,2,47,23,203,2,23,204,1,248,22,
98,23,199,1,28,249,22,151,7,23,196,2,2,27,249,22,78,23,202,2,194,
249,22,64,248,22,145,13,23,197,1,23,195,1,87,95,23,199,1,23,193,1,
28,249,22,151,7,23,196,2,2,27,249,22,78,23,200,2,9,249,22,64,248,
22,145,13,23,197,1,9,28,249,22,151,7,23,196,2,2,27,249,22,78,197,
194,87,94,23,196,1,249,22,64,248,22,145,13,23,197,1,194,87,94,23,193,
1,28,249,22,151,7,23,198,2,2,27,249,22,78,195,9,87,94,23,194,1,
249,22,64,248,22,145,13,23,199,1,9,87,95,28,28,248,22,145,7,194,10,
248,22,157,6,194,12,250,22,129,9,2,13,6,21,21,98,121,116,101,32,115,
116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22,73,
195,249,22,4,22,136,13,196,11,12,250,22,129,9,2,13,6,13,13,108,105,
115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22,157,
6,197,248,22,168,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33,53,
32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222,33,
52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,157,13,23,199,2,
87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,162,13,23,201,2,
28,249,22,164,8,23,195,2,23,202,2,11,28,248,22,158,13,23,194,2,250,
2,51,23,201,2,23,202,2,249,22,154,13,23,200,2,23,198,1,250,2,51,
23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1,27,
28,248,22,136,13,23,196,2,27,249,22,154,13,23,198,2,23,201,2,28,28,
248,22,149,13,193,10,248,22,148,13,193,192,11,11,28,23,193,2,192,87,94,
23,193,1,28,23,199,2,11,27,248,22,162,13,23,202,2,28,249,22,164,8,
23,195,2,23,203,1,11,28,248,22,158,13,23,194,2,250,2,51,23,202,1,
23,203,1,249,22,154,13,23,201,1,23,198,1,250,2,51,201,202,195,194,28,
248,22,72,23,197,2,11,27,248,22,161,13,248,22,65,23,199,2,27,249,22,
154,13,23,196,1,23,197,2,28,248,22,148,13,23,194,2,250,2,51,198,199,
195,87,94,23,193,1,27,248,22,66,23,200,1,28,248,22,72,23,194,2,11,
27,248,22,161,13,248,22,65,23,196,2,27,249,22,154,13,23,196,1,23,200,
2,28,248,22,148,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,27,
248,22,66,23,197,1,28,248,22,72,23,194,2,11,27,248,22,161,13,248,22,
65,195,27,249,22,154,13,23,196,1,202,28,248,22,148,13,193,250,2,51,204,
205,195,251,2,50,204,205,206,248,22,66,199,87,95,28,27,248,22,136,13,23,
196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,157,6,23,196,2,27,
248,22,158,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,159,13,
23,197,2,11,12,250,22,129,9,2,14,6,25,25,112,97,116,104,32,111,114,
32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197,2,
28,28,23,195,2,28,27,248,22,136,13,23,197,2,28,23,193,2,192,87,94,
23,193,1,28,248,22,157,6,23,197,2,27,248,22,158,13,23,198,2,28,23,
193,2,192,87,94,23,193,1,248,22,159,13,23,198,2,11,248,22,158,13,23,
196,2,11,10,12,250,22,129,9,2,14,6,29,29,35,102,32,111,114,32,114,
101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105,110,
103,23,198,2,28,28,248,22,158,13,23,195,2,91,159,38,11,90,161,38,35,
11,248,22,157,13,23,198,2,249,22,162,8,194,68,114,101,108,97,116,105,118,
101,11,27,248,22,174,7,6,4,4,80,65,84,72,251,2,50,23,199,1,23,
200,1,23,201,1,28,23,197,2,27,249,80,158,43,47,23,200,1,9,28,249,
22,162,8,247,22,176,7,2,20,249,22,64,248,22,145,13,5,1,46,23,195,
1,192,9,27,248,22,161,13,23,196,1,28,248,22,148,13,193,250,2,51,198,
199,195,11,250,80,158,38,48,196,197,11,250,80,158,38,48,196,11,11,87,94,
249,22,148,6,247,22,184,4,195,248,22,174,5,249,22,170,3,35,249,22,154,
3,197,198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1,87,94,
23,197,1,27,248,22,175,13,2,19,27,249,80,158,40,48,23,196,1,11,27,
27,248,22,173,3,23,200,1,28,192,192,35,27,27,248,22,173,3,23,202,1,
28,192,192,35,249,22,151,5,23,197,1,83,158,39,20,97,95,89,162,8,44,
35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,136,5,23,195,
1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1,11,16,0,83,158,
41,20,100,143,67,35,37,117,116,105,108,115,29,11,11,11,11,10,10,42,80,
158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2,4,2,5,2,6,
2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,2,15,30,2,17,
1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,
121,4,30,2,17,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,
101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,0,35,16,0,35,16,
4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11,16,11,2,7,2,
6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,16,11,
11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2,6,2,15,2,14,
2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46,36,11,11,16,0,
16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,17,
83,158,35,16,2,89,162,43,36,48,2,18,223,0,33,28,80,159,35,53,36,
83,158,35,16,2,89,162,8,44,36,55,2,18,223,0,33,29,80,159,35,52,
36,83,158,35,16,2,32,0,89,162,43,36,44,2,1,222,33,30,80,159,35,
35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,36,36,83,
158,35,16,2,89,162,43,36,53,2,3,223,0,33,31,80,159,35,37,36,83,
158,35,16,2,32,0,89,162,8,44,37,49,2,4,222,33,32,80,159,35,38,
36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,5,222,33,34,80,159,
35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,6,223,0,33,36,80,
159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,7,222,33,39,
80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,8,222,33,
40,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,2,9,222,
33,41,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,53,2,10,
222,33,42,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,36,43,2,
11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158,38,20,96,96,2,
12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44,9,223,0,33,45,
89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83,158,35,16,2,27,
248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,2,20,6,
1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,97,93,42,
41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,47,2,13,
223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158,38,20,96,96,2,
14,89,162,8,44,38,53,9,223,0,33,54,89,162,43,37,46,9,223,0,33,
55,89,162,43,36,45,9,223,0,33,56,80,159,35,48,36,83,158,35,16,2,
89,162,43,38,51,2,15,223,0,33,58,80,159,35,49,36,94,29,94,2,16,
68,35,37,107,101,114,110,101,108,11,29,94,2,16,69,35,37,109,105,110,45,
115,116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5006);
2,92,49,80,159,43,36,37,2,20,28,248,22,158,6,194,248,22,146,13,194,
193,87,94,28,27,248,22,138,13,23,196,2,28,23,193,2,192,87,94,23,193,
1,28,248,22,158,6,23,196,2,27,248,22,160,13,23,197,2,28,23,193,2,
192,87,94,23,193,1,248,22,161,13,23,197,2,11,12,250,22,131,9,23,196,
2,2,21,23,197,2,28,248,22,160,13,23,195,2,12,248,22,157,11,249,22,
166,10,248,22,187,6,250,22,142,7,2,22,23,200,1,23,201,1,247,22,23,
87,94,28,27,248,22,138,13,23,196,2,28,23,193,2,192,87,94,23,193,1,
28,248,22,158,6,23,196,2,27,248,22,160,13,23,197,2,28,23,193,2,192,
87,94,23,193,1,248,22,161,13,23,197,2,11,12,250,22,131,9,23,196,2,
2,21,23,197,2,28,248,22,160,13,23,195,2,12,248,22,157,11,249,22,166,
10,248,22,187,6,250,22,142,7,2,22,23,200,1,23,201,1,247,22,23,87,
94,87,94,28,27,248,22,138,13,23,196,2,28,23,193,2,192,87,94,23,193,
1,28,248,22,158,6,23,196,2,27,248,22,160,13,23,197,2,28,23,193,2,
192,87,94,23,193,1,248,22,161,13,23,197,2,11,12,250,22,131,9,195,2,
21,23,197,2,28,248,22,160,13,23,195,2,12,248,22,157,11,249,22,166,10,
248,22,187,6,250,22,142,7,2,22,199,23,201,1,247,22,23,249,22,3,89,
162,8,44,36,49,9,223,2,33,33,196,248,22,157,11,249,22,132,11,23,196,
1,247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41,
36,2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162,
43,41,58,65,99,108,111,111,112,222,33,38,28,248,22,73,23,199,2,87,94,
23,198,1,248,23,196,1,251,22,142,7,2,23,23,199,1,28,248,22,73,23,
203,2,87,94,23,202,1,23,201,1,250,22,1,22,156,13,23,204,1,23,205,
1,23,198,1,27,249,22,156,13,248,22,66,23,202,2,23,199,2,28,248,22,
151,13,23,194,2,27,250,22,1,22,156,13,23,197,1,23,202,2,28,248,22,
151,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22,
73,23,194,2,87,94,23,193,1,248,23,199,1,251,22,142,7,2,23,23,202,
1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,156,
13,23,207,1,23,208,1,23,201,1,27,249,22,156,13,248,22,66,23,197,2,
23,202,2,28,248,22,151,13,23,194,2,27,250,22,1,22,156,13,23,197,1,
204,28,248,22,151,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201,
253,2,37,202,203,204,205,206,248,22,67,200,87,94,23,193,1,27,248,22,67,
23,201,1,28,248,22,73,23,194,2,87,94,23,193,1,248,23,198,1,251,22,
142,7,2,23,23,201,1,28,248,22,73,23,205,2,87,94,23,204,1,23,203,
1,250,22,1,22,156,13,23,206,1,23,207,1,23,200,1,27,249,22,156,13,
248,22,66,23,197,2,23,201,2,28,248,22,151,13,23,194,2,27,250,22,1,
22,156,13,23,197,1,203,28,248,22,151,13,193,192,253,2,37,202,203,204,205,
206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,179,
13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,139,13,23,194,2,
10,27,248,22,138,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248,
22,158,6,23,195,2,27,248,22,160,13,23,196,2,28,23,193,2,192,87,94,
23,193,1,248,22,161,13,23,196,2,11,12,252,22,131,9,23,200,2,2,24,
35,23,198,2,23,199,2,28,28,248,22,158,6,23,195,2,10,248,22,146,7,
23,195,2,87,94,23,194,1,12,252,22,131,9,23,200,2,2,25,36,23,198,
2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,159,13,23,197,2,87,
94,23,195,1,87,94,28,192,12,250,22,132,9,23,201,1,2,26,23,199,1,
249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,139,
13,23,196,2,10,27,248,22,138,13,23,197,2,28,23,193,2,192,87,94,23,
193,1,28,248,22,158,6,23,197,2,27,248,22,160,13,23,198,2,28,23,193,
2,192,87,94,23,193,1,248,22,161,13,23,198,2,11,12,252,22,131,9,2,
9,2,24,35,23,200,2,23,201,2,28,28,248,22,158,6,23,197,2,10,248,
22,146,7,23,197,2,12,252,22,131,9,2,9,2,25,36,23,200,2,23,201,
2,91,159,38,11,90,161,38,35,11,248,22,159,13,23,199,2,87,94,23,195,
1,87,94,28,192,12,250,22,132,9,2,9,2,26,23,201,2,249,22,7,194,
195,27,249,22,148,13,250,22,131,14,0,18,35,114,120,35,34,40,91,46,93,
91,94,46,93,42,124,41,36,34,248,22,144,13,23,201,1,28,248,22,158,6,
23,203,2,249,22,170,7,23,204,1,8,63,23,202,1,28,248,22,139,13,23,
199,2,248,22,140,13,23,199,1,87,94,23,198,1,247,22,141,13,28,248,22,
138,13,194,249,22,156,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95,
28,28,248,22,139,13,23,196,2,10,27,248,22,138,13,23,197,2,28,23,193,
2,192,87,94,23,193,1,28,248,22,158,6,23,197,2,27,248,22,160,13,23,
198,2,28,23,193,2,192,87,94,23,193,1,248,22,161,13,23,198,2,11,12,
252,22,131,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,158,6,
23,197,2,10,248,22,146,7,23,197,2,12,252,22,131,9,2,10,2,25,36,
23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,159,13,23,199,
2,87,94,23,195,1,87,94,28,192,12,250,22,132,9,2,10,2,26,23,201,
2,249,22,7,194,195,27,249,22,148,13,249,22,156,7,250,22,132,14,0,9,
35,114,120,35,34,91,46,93,34,248,22,144,13,23,203,1,6,1,1,95,28,
248,22,158,6,23,202,2,249,22,170,7,23,203,1,8,63,23,201,1,28,248,
22,139,13,23,199,2,248,22,140,13,23,199,1,87,94,23,198,1,247,22,141,
13,28,248,22,138,13,194,249,22,156,13,195,194,192,249,247,22,189,4,194,11,
249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,181,13,249,80,
158,38,47,28,23,195,2,27,248,22,175,7,6,11,11,80,76,84,67,79,76,
76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,196,1,250,22,
156,13,248,22,177,13,69,97,100,100,111,110,45,100,105,114,247,22,173,7,6,
8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,36,250,22,79,
23,203,1,248,22,75,248,22,177,13,72,99,111,108,108,101,99,116,115,45,100,
105,114,23,204,1,28,23,194,2,249,22,65,23,196,1,23,195,1,192,32,47,
89,162,8,44,38,54,2,18,222,33,48,27,249,22,188,13,23,197,2,23,198,
2,28,23,193,2,87,94,23,196,1,27,248,22,90,23,195,2,27,27,248,22,
99,23,197,1,27,249,22,188,13,23,201,2,23,196,2,28,23,193,2,87,94,
23,194,1,27,248,22,90,23,195,2,27,250,2,47,23,203,2,23,204,1,248,
22,99,23,199,1,28,249,22,152,7,23,196,2,2,27,249,22,79,23,202,2,
194,249,22,65,248,22,147,13,23,197,1,23,195,1,87,95,23,199,1,23,193,
1,28,249,22,152,7,23,196,2,2,27,249,22,79,23,200,2,9,249,22,65,
248,22,147,13,23,197,1,9,28,249,22,152,7,23,196,2,2,27,249,22,79,
197,194,87,94,23,196,1,249,22,65,248,22,147,13,23,197,1,194,87,94,23,
193,1,28,249,22,152,7,23,198,2,2,27,249,22,79,195,9,87,94,23,194,
1,249,22,65,248,22,147,13,23,199,1,9,87,95,28,28,248,22,146,7,194,
10,248,22,158,6,194,12,250,22,131,9,2,13,6,21,21,98,121,116,101,32,
115,116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22,
74,195,249,22,4,22,138,13,196,11,12,250,22,131,9,2,13,6,13,13,108,
105,115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22,
158,6,197,248,22,169,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33,
53,32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222,
33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,159,13,23,199,
2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,164,13,23,201,
2,28,249,22,165,8,23,195,2,23,202,2,11,28,248,22,160,13,23,194,2,
250,2,51,23,201,2,23,202,2,249,22,156,13,23,200,2,23,198,1,250,2,
51,23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1,
27,28,248,22,138,13,23,196,2,27,249,22,156,13,23,198,2,23,201,2,28,
28,248,22,151,13,193,10,248,22,150,13,193,192,11,11,28,23,193,2,192,87,
94,23,193,1,28,23,199,2,11,27,248,22,164,13,23,202,2,28,249,22,165,
8,23,195,2,23,203,1,11,28,248,22,160,13,23,194,2,250,2,51,23,202,
1,23,203,1,249,22,156,13,23,201,1,23,198,1,250,2,51,201,202,195,194,
28,248,22,73,23,197,2,11,27,248,22,163,13,248,22,66,23,199,2,27,249,
22,156,13,23,196,1,23,197,2,28,248,22,150,13,23,194,2,250,2,51,198,
199,195,87,94,23,193,1,27,248,22,67,23,200,1,28,248,22,73,23,194,2,
11,27,248,22,163,13,248,22,66,23,196,2,27,249,22,156,13,23,196,1,23,
200,2,28,248,22,150,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,
27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,163,13,248,
22,66,195,27,249,22,156,13,23,196,1,202,28,248,22,150,13,193,250,2,51,
204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22,138,13,
23,196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,158,6,23,196,2,
27,248,22,160,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,161,
13,23,197,2,11,12,250,22,131,9,2,14,6,25,25,112,97,116,104,32,111,
114,32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197,
2,28,28,23,195,2,28,27,248,22,138,13,23,197,2,28,23,193,2,192,87,
94,23,193,1,28,248,22,158,6,23,197,2,27,248,22,160,13,23,198,2,28,
23,193,2,192,87,94,23,193,1,248,22,161,13,23,198,2,11,248,22,160,13,
23,196,2,11,10,12,250,22,131,9,2,14,6,29,29,35,102,32,111,114,32,
114,101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105,
110,103,23,198,2,28,28,248,22,160,13,23,195,2,91,159,38,11,90,161,38,
35,11,248,22,159,13,23,198,2,249,22,163,8,194,68,114,101,108,97,116,105,
118,101,11,27,248,22,175,7,6,4,4,80,65,84,72,251,2,50,23,199,1,
23,200,1,23,201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9,
28,249,22,163,8,247,22,177,7,2,20,249,22,65,248,22,147,13,5,1,46,
23,195,1,192,9,27,248,22,163,13,23,196,1,28,248,22,150,13,193,250,2,
51,198,199,195,11,250,80,158,38,48,196,197,11,250,80,158,38,48,196,11,11,
87,94,249,22,149,6,247,22,185,4,195,248,22,175,5,249,22,171,3,35,249,
22,155,3,197,198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1,
87,94,23,197,1,27,248,22,177,13,2,19,27,249,80,159,40,48,37,23,196,
1,11,27,27,248,22,174,3,23,200,1,28,192,192,35,27,27,248,22,174,3,
23,202,1,28,192,192,35,249,22,152,5,23,197,1,83,158,39,20,97,95,89,
162,8,44,35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,137,
5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1,11,16,
0,83,158,41,20,100,143,67,35,37,117,116,105,108,115,29,11,11,11,11,10,
10,42,80,158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2,4,2,
5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,2,15,
30,2,17,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
45,107,101,121,4,30,2,17,1,23,101,120,116,101,110,100,45,112,97,114,97,
109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,0,35,16,
0,35,16,4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11,16,11,
2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,
1,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2,6,2,
15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46,36,11,
11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,
0,16,17,83,158,35,16,2,89,162,43,36,48,2,18,223,0,33,28,80,159,
35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,18,223,0,33,29,80,
159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,1,222,33,30,
80,159,35,35,36,83,158,35,16,2,249,22,160,6,7,92,7,92,80,159,35,
36,36,83,158,35,16,2,89,162,43,36,53,2,3,223,0,33,31,80,159,35,
37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,4,222,33,32,80,
159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,5,222,33,
34,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,6,223,0,
33,36,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,7,
222,33,39,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,
8,222,33,40,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,
2,9,222,33,41,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,
53,2,10,222,33,42,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,
36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158,38,20,
96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44,9,223,
0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83,158,35,
16,2,27,248,22,184,13,248,22,169,7,27,28,249,22,163,8,247,22,177,7,
2,20,6,1,1,59,6,1,1,58,250,22,142,7,6,14,14,40,91,94,126,
97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,
47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158,38,20,
96,96,2,14,89,162,8,44,38,53,9,223,0,33,54,89,162,43,37,46,9,
223,0,33,55,89,162,43,36,45,9,223,0,33,56,80,159,35,48,36,83,158,
35,16,2,89,162,43,38,51,2,15,223,0,33,58,80,159,35,49,36,94,29,
94,2,16,68,35,37,107,101,114,110,101,108,11,29,94,2,16,69,35,37,109,
105,110,45,115,116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5009);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,54,8,0,0,0,1,0,0,6,0,19,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,56,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,111,0,0,0,1,1,0,0,65,113,117,111,116,
101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
@ -360,12 +360,12 @@
EVAL_ONE_SIZED_STR((char *)expr, 294);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,54,52,0,0,0,1,0,0,11,0,38,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,56,52,0,0,0,1,0,0,11,0,38,0,
44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220,
0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,80,1,
88,1,191,1,236,1,0,2,28,2,59,2,114,2,124,2,171,2,181,2,188,
2,75,4,88,4,107,4,226,4,238,4,134,5,148,5,12,6,18,6,32,6,
59,6,144,6,146,6,211,6,146,12,205,12,237,12,0,0,116,15,0,0,70,
0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1,
89,1,196,1,241,1,5,2,34,2,65,2,121,2,131,2,178,2,188,2,195,
2,82,4,95,4,114,4,233,4,245,4,141,5,155,5,21,6,27,6,41,6,
68,6,153,6,155,6,221,6,166,12,225,12,3,13,0,0,138,15,0,0,70,
100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116,45,108,
111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117,111,116,
101,29,94,2,3,67,35,37,117,116,105,108,115,11,29,94,2,3,68,35,37,
@ -381,179 +381,180 @@
118,101,114,64,98,111,111,116,64,115,97,109,101,5,3,46,122,111,6,6,6,
110,97,116,105,118,101,64,108,111,111,112,1,29,115,116,97,110,100,97,114,100,
45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,
63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,158,37,45,249,
80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,162,8,23,197,2,80,
158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,171,4,23,197,2,28,
248,22,136,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,157,13,23,
197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40,47,
192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,189,4,28,192,
192,247,22,176,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27,11,
80,158,40,39,22,189,4,28,248,22,136,13,23,198,2,23,197,1,87,94,23,
197,1,247,22,176,13,247,194,250,22,154,13,23,197,1,23,199,1,249,80,158,
42,38,23,198,1,2,17,252,22,154,13,23,199,1,23,201,1,2,18,247,22,
177,7,249,80,158,44,38,23,200,1,80,158,44,35,87,94,23,194,1,27,250,
22,171,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,64,
195,194,11,27,252,22,154,13,23,200,1,23,202,1,2,18,247,22,177,7,249,
80,158,45,38,23,201,1,80,158,45,35,27,250,22,171,13,196,11,32,0,89,
162,8,44,35,40,9,222,11,28,192,249,22,64,195,194,11,249,247,22,181,13,
248,22,65,195,195,27,250,22,154,13,23,198,1,23,200,1,249,80,158,43,38,
23,199,1,2,17,27,250,22,171,13,196,11,32,0,89,162,8,44,35,40,9,
222,11,28,192,249,22,64,195,194,11,249,247,22,187,4,248,22,65,195,195,249,
247,22,187,4,194,195,87,94,28,248,80,158,36,37,23,195,2,12,250,22,129,
9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,6,25,
25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116,104,32,115,
116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28,248,22,160,
13,23,201,2,23,200,1,27,247,22,189,4,28,23,193,2,249,22,161,13,23,
203,1,23,195,1,200,90,161,38,36,11,248,22,157,13,23,194,2,87,94,23,
196,1,90,161,36,39,11,28,249,22,162,8,23,196,2,68,114,101,108,97,116,
105,118,101,87,94,23,194,1,2,16,23,194,1,90,161,36,40,11,247,22,178,
13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89,162,43,36,
51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44,36,46,9,223,5,
33,29,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44,36,52,9,
225,13,11,9,33,30,23,205,2,27,28,23,196,2,11,193,28,192,192,28,193,
28,23,196,2,28,249,22,166,3,248,22,66,196,248,22,66,23,199,2,193,11,
11,11,11,28,23,193,2,249,80,159,47,54,36,202,89,162,43,35,45,9,224,
14,2,33,31,87,94,23,193,1,27,28,23,197,1,27,249,22,5,83,158,39,
20,97,94,89,162,8,44,36,50,9,225,14,12,10,33,32,23,203,1,23,206,
1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22,166,3,248,22,66,
196,248,22,66,199,193,11,11,11,11,28,192,249,80,159,48,54,36,203,89,162,
43,35,45,9,224,15,2,33,33,249,80,159,48,54,36,203,89,162,43,35,44,
9,224,15,7,33,34,32,36,89,162,8,44,36,54,2,19,222,33,38,0,17,
35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27,249,22,186,
13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,64,248,22,89,
23,196,2,27,248,22,98,23,197,1,27,249,22,186,13,2,37,23,196,2,28,
23,193,2,87,94,23,194,1,249,22,64,248,22,89,23,196,2,27,248,22,98,
23,197,1,27,249,22,186,13,2,37,23,196,2,28,23,193,2,87,94,23,194,
1,249,22,64,248,22,89,23,196,2,248,2,36,248,22,98,23,197,1,248,22,
74,194,248,22,74,194,248,22,74,194,32,39,89,162,43,36,54,2,19,222,33,
40,28,248,22,72,248,22,66,23,195,2,249,22,7,9,248,22,65,195,91,159,
37,11,90,161,37,35,11,27,248,22,66,23,197,2,28,248,22,72,248,22,66,
23,195,2,249,22,7,9,248,22,65,195,91,159,37,11,90,161,37,35,11,27,
248,22,66,23,197,2,28,248,22,72,248,22,66,23,195,2,249,22,7,9,248,
22,65,195,91,159,37,11,90,161,37,35,11,248,2,39,248,22,66,23,197,2,
249,22,7,249,22,64,248,22,65,23,200,1,23,197,1,195,249,22,7,249,22,
64,248,22,65,23,200,1,23,197,1,195,249,22,7,249,22,64,248,22,65,23,
200,1,23,197,1,195,27,248,2,36,23,195,1,28,194,192,248,2,39,193,87,
95,28,248,22,169,4,195,12,250,22,129,9,2,20,6,20,20,114,101,115,111,
108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,197,28,24,193,2,
248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,138,2,80,158,41,42,
248,22,142,14,247,22,183,11,11,28,23,193,2,192,87,94,23,193,1,27,247,
22,122,87,94,250,22,136,2,80,158,42,42,248,22,142,14,247,22,183,11,195,
192,250,22,136,2,195,198,66,97,116,116,97,99,104,251,211,197,198,199,10,28,
192,250,22,128,9,11,196,195,248,22,190,8,194,28,249,22,163,6,194,6,1,
1,46,2,16,28,249,22,163,6,194,6,2,2,46,46,62,117,112,192,28,249,
22,164,8,248,22,66,23,200,2,23,197,1,28,249,22,162,8,248,22,65,23,
200,2,23,196,1,251,22,190,8,2,20,6,26,26,99,121,99,108,101,32,105,
110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58,32,126,101,23,200,
1,249,22,2,22,66,248,22,79,249,22,64,23,206,1,23,202,1,12,12,247,
192,20,14,159,80,158,39,44,249,22,64,248,22,142,14,247,22,183,11,23,197,
1,20,14,159,80,158,39,39,250,80,158,42,40,249,22,27,11,80,158,44,39,
22,151,4,23,196,1,249,247,22,188,4,23,198,1,248,22,53,248,22,140,13,
23,198,1,87,94,28,28,248,22,136,13,23,197,2,10,248,22,175,4,23,197,
2,12,28,23,198,2,250,22,128,9,11,6,15,15,98,97,100,32,109,111,100,
117,108,101,32,112,97,116,104,23,201,2,250,22,129,9,2,20,6,19,19,109,
111,100,117,108,101,45,112,97,116,104,32,111,114,32,112,97,116,104,23,199,2,
28,28,248,22,62,23,197,2,249,22,162,8,248,22,65,23,199,2,2,3,11,
248,22,170,4,248,22,89,197,28,28,248,22,62,23,197,2,249,22,162,8,248,
22,65,23,199,2,66,112,108,97,110,101,116,11,87,94,28,207,12,20,14,159,
80,158,37,39,250,80,158,40,40,249,22,27,11,80,158,42,39,22,183,11,23,
197,1,90,161,36,35,10,249,22,152,4,21,94,2,21,6,18,18,112,108,97,
110,101,116,47,114,101,115,111,108,118,101,114,46,115,115,1,27,112,108,97,110,
101,116,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,
101,114,12,251,211,199,200,201,202,87,94,23,193,1,27,89,162,8,44,36,45,
79,115,104,111,119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,223,
6,33,44,27,28,248,22,52,23,199,2,27,250,22,138,2,80,158,43,43,249,
22,64,23,204,2,247,22,177,13,11,28,23,193,2,192,87,94,23,193,1,91,
159,37,11,90,161,37,35,11,249,80,159,44,48,36,248,22,55,23,204,2,11,
27,251,80,158,47,50,2,20,23,202,1,28,248,22,72,23,199,2,23,199,2,
248,22,65,23,199,2,28,248,22,72,23,199,2,9,248,22,66,23,199,2,249,
22,154,13,23,195,1,28,248,22,72,23,197,1,87,94,23,197,1,6,7,7,
109,97,105,110,46,115,115,249,22,180,6,23,199,1,6,3,3,46,115,115,28,
248,22,157,6,23,199,2,87,94,23,194,1,27,248,80,159,41,55,36,23,201,
2,27,250,22,138,2,80,158,44,43,249,22,64,23,205,2,23,199,2,11,28,
23,193,2,192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,
45,48,36,23,204,2,11,250,22,1,22,154,13,23,199,1,249,22,78,249,22,
2,32,0,89,162,8,44,36,43,9,222,33,45,23,200,1,248,22,74,23,200,
1,28,248,22,136,13,23,199,2,87,94,23,194,1,28,248,22,159,13,23,199,
2,23,198,2,248,22,74,6,26,26,32,40,97,32,112,97,116,104,32,109,117,
115,116,32,98,101,32,97,98,115,111,108,117,116,101,41,28,249,22,162,8,248,
22,65,23,201,2,2,21,27,250,22,138,2,80,158,43,43,249,22,64,23,204,
2,247,22,177,13,11,28,23,193,2,192,87,94,23,193,1,91,159,38,11,90,
161,37,35,11,249,80,159,45,48,36,248,22,89,23,205,2,11,90,161,36,37,
11,28,248,22,72,248,22,91,23,204,2,28,248,22,72,23,194,2,249,22,188,
13,0,8,35,114,120,34,91,46,93,34,23,196,2,11,10,27,27,28,23,197,
2,249,22,78,28,248,22,72,248,22,91,23,208,2,21,93,6,5,5,109,122,
108,105,98,249,22,1,22,78,249,22,2,80,159,51,56,36,248,22,91,23,211,
2,23,197,2,28,248,22,72,23,196,2,248,22,74,23,197,2,23,195,2,251,
80,158,49,50,2,20,23,204,1,248,22,65,23,198,2,248,22,66,23,198,1,
249,22,154,13,23,195,1,28,23,198,1,87,94,23,196,1,23,197,1,28,248,
22,72,23,197,1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,28,
249,22,188,13,0,8,35,114,120,34,91,46,93,34,23,199,2,23,197,1,249,
22,180,6,23,199,1,6,3,3,46,115,115,28,249,22,162,8,248,22,65,23,
201,2,64,102,105,108,101,249,22,161,13,248,22,165,13,248,22,89,23,202,2,
248,80,159,42,55,36,23,202,2,12,87,94,28,28,248,22,136,13,23,194,2,
10,248,22,179,7,23,194,2,87,94,23,200,1,12,28,23,200,2,250,22,128,
9,67,114,101,113,117,105,114,101,249,22,141,7,6,17,17,98,97,100,32,109,
111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,65,23,199,
2,6,0,0,23,203,1,87,94,23,200,1,250,22,129,9,2,20,249,22,141,
7,6,13,13,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,
248,22,65,23,199,2,6,0,0,23,201,2,27,28,248,22,179,7,23,195,2,
249,22,184,7,23,196,2,35,249,22,163,13,248,22,164,13,23,197,2,11,27,
28,248,22,179,7,23,196,2,249,22,184,7,23,197,2,36,248,80,158,42,51,
23,195,2,91,159,38,11,90,161,38,35,11,28,248,22,179,7,23,199,2,250,
22,7,2,22,249,22,184,7,23,203,2,37,2,22,248,22,157,13,23,198,2,
87,95,23,195,1,23,193,1,27,28,248,22,179,7,23,200,2,249,22,184,7,
23,201,2,38,249,80,158,47,52,23,197,2,5,0,27,28,248,22,179,7,23,
201,2,249,22,184,7,23,202,2,39,248,22,170,4,23,200,2,27,27,250,22,
138,2,80,158,51,42,248,22,142,14,247,22,183,11,11,28,23,193,2,192,87,
94,23,193,1,27,247,22,122,87,94,250,22,136,2,80,158,52,42,248,22,142,
14,247,22,183,11,195,192,87,95,28,23,209,1,27,250,22,138,2,23,197,2,
197,11,28,23,193,1,12,87,95,27,27,28,248,22,17,80,158,51,45,80,158,
50,45,247,22,19,250,22,25,248,22,23,23,197,2,80,158,53,44,23,196,1,
27,248,22,142,14,247,22,183,11,249,22,3,83,158,39,20,97,94,89,162,8,
44,36,54,9,226,12,11,2,3,33,46,23,195,1,23,196,1,248,28,248,22,
17,80,158,50,45,32,0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,
89,162,43,35,50,9,227,14,9,8,4,3,33,48,250,22,136,2,23,197,1,
197,10,12,28,28,248,22,179,7,23,202,1,11,27,248,22,157,6,23,208,2,
28,192,192,28,248,22,62,23,208,2,249,22,162,8,248,22,65,23,210,2,2,
21,11,250,22,136,2,80,158,50,43,28,248,22,157,6,23,210,2,249,22,64,
23,211,1,248,80,159,53,55,36,23,213,1,87,94,23,210,1,249,22,64,23,
211,1,247,22,177,13,252,22,181,7,23,208,1,23,207,1,23,205,1,23,203,
1,201,12,193,91,159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,
38,20,96,96,2,20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,
38,48,9,223,1,33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,
87,95,248,22,150,4,248,80,158,37,49,247,22,183,11,248,22,188,4,80,158,
36,36,248,22,174,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11,16,
0,83,158,41,20,100,143,66,35,37,98,111,111,116,29,11,11,11,11,10,10,
36,80,158,35,35,20,103,159,39,16,19,2,1,2,2,30,2,4,72,112,97,
116,104,45,115,116,114,105,110,103,63,10,30,2,4,75,112,97,116,104,45,97,
100,100,45,115,117,102,102,105,120,7,30,2,5,1,20,112,97,114,97,109,101,
116,101,114,105,122,97,116,105,111,110,45,107,101,121,4,30,2,5,1,23,101,
120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,
110,3,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,30,
2,4,69,45,102,105,110,100,45,99,111,108,0,30,2,4,76,110,111,114,109,
97,108,45,99,97,115,101,45,112,97,116,104,6,30,2,4,79,112,97,116,104,
45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,9,2,15,16,0,11,
11,16,0,35,16,0,35,16,11,2,9,2,10,2,7,2,8,2,11,2,12,
2,2,2,6,2,1,2,14,2,13,46,11,11,38,35,11,11,16,1,2,15,
16,1,11,16,1,2,15,36,36,36,11,11,16,0,16,0,16,0,35,35,11,
11,11,16,0,16,0,16,0,35,35,16,0,16,16,83,158,35,16,2,89,162,
43,36,44,9,223,0,33,23,80,159,35,57,36,83,158,35,16,2,89,162,43,
36,44,9,223,0,33,24,80,159,35,56,36,83,158,35,16,2,89,162,43,36,
48,67,103,101,116,45,100,105,114,223,0,33,25,80,159,35,55,36,83,158,35,
16,2,89,162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,26,80,
159,35,54,36,83,158,35,16,2,248,22,176,7,69,115,111,45,115,117,102,102,
105,120,80,159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,2,223,0,
33,35,80,159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,
6,222,192,80,159,35,41,36,83,158,35,16,2,247,22,125,80,159,35,42,36,
83,158,35,16,2,247,22,124,80,159,35,43,36,83,158,35,16,2,247,22,60,
80,159,35,44,36,83,158,35,16,2,248,22,18,74,109,111,100,117,108,101,45,
108,111,97,100,105,110,103,80,159,35,45,36,83,158,35,16,2,11,80,158,35,
46,83,158,35,16,2,11,80,158,35,47,83,158,35,16,2,32,0,89,162,43,
37,44,2,13,222,33,41,80,159,35,48,36,83,158,35,16,2,89,162,8,44,
36,44,2,14,223,0,33,50,80,159,35,49,36,83,158,35,16,2,89,162,43,
35,43,2,15,223,0,33,51,80,159,35,53,36,95,29,94,2,3,68,35,37,
107,101,114,110,101,108,11,29,94,2,3,69,35,37,109,105,110,45,115,116,120,
11,2,4,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4081);
63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37,
249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,163,8,23,197,2,
80,159,38,46,37,87,94,23,195,1,80,159,36,47,37,27,248,22,172,4,23,
197,2,28,248,22,138,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,
159,13,23,197,1,87,95,83,160,37,11,80,159,40,46,37,198,83,160,37,11,
80,159,40,47,37,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,
22,190,4,28,192,192,247,22,178,13,20,14,159,80,158,35,39,250,80,158,38,
40,249,22,27,11,80,158,40,39,22,190,4,28,248,22,138,13,23,198,2,23,
197,1,87,94,23,197,1,247,22,178,13,247,194,250,22,156,13,23,197,1,23,
199,1,249,80,158,42,38,23,198,1,2,17,252,22,156,13,23,199,1,23,201,
1,2,18,247,22,178,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,
94,23,194,1,27,250,22,173,13,196,11,32,0,89,162,8,44,35,40,9,222,
11,28,192,249,22,65,195,194,11,27,252,22,156,13,23,200,1,23,202,1,2,
18,247,22,178,7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,
173,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,
194,11,249,247,22,183,13,248,22,66,195,195,27,250,22,156,13,23,198,1,23,
200,1,249,80,158,43,38,23,199,1,2,17,27,250,22,173,13,196,11,32,0,
89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,188,
4,248,22,66,195,195,249,247,22,188,4,194,195,87,94,28,248,80,158,36,37,
23,195,2,12,250,22,131,9,77,108,111,97,100,47,117,115,101,45,99,111,109,
112,105,108,101,100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100,
45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161,
36,35,11,28,248,22,162,13,23,201,2,23,200,1,27,247,22,190,4,28,23,
193,2,249,22,163,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,159,
13,23,194,2,87,94,23,196,1,90,161,36,39,11,28,249,22,163,8,23,196,
2,68,114,101,108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90,
161,36,40,11,247,22,180,13,27,89,162,43,36,49,62,122,111,225,7,5,3,
33,27,27,89,162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162,
8,44,36,46,9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5,
89,162,8,44,36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2,
11,193,28,192,192,28,193,28,23,196,2,28,249,22,167,3,248,22,67,196,248,
22,67,23,199,2,193,11,11,11,11,28,23,193,2,249,80,159,47,54,36,202,
89,162,43,35,45,9,224,14,2,33,31,87,94,23,193,1,27,28,23,197,1,
27,249,22,5,83,158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10,
33,32,23,203,1,23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,
249,22,167,3,248,22,67,196,248,22,67,199,193,11,11,11,11,28,192,249,80,
159,48,54,36,203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54,
36,203,89,162,43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54,
2,19,222,33,38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,
41,36,34,27,249,22,188,13,2,37,23,196,2,28,23,193,2,87,94,23,194,
1,249,22,65,248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,188,
13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90,
23,196,2,27,248,22,99,23,197,1,27,249,22,188,13,2,37,23,196,2,28,
23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248,
22,99,23,197,1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162,
43,36,54,2,19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7,
9,248,22,66,195,91,159,37,11,90,161,37,35,11,27,248,22,67,23,197,2,
28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66,195,91,159,37,
11,90,161,37,35,11,27,248,22,67,23,197,2,28,248,22,73,248,22,67,23,
195,2,249,22,7,9,248,22,66,195,91,159,37,11,90,161,37,35,11,248,2,
39,248,22,67,23,197,2,249,22,7,249,22,65,248,22,66,23,200,1,23,197,
1,195,249,22,7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22,7,
249,22,65,248,22,66,23,200,1,23,197,1,195,27,248,2,36,23,195,1,28,
194,192,248,2,39,193,87,95,28,248,22,170,4,195,12,250,22,131,9,2,20,
6,20,20,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,
116,104,197,28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,
22,139,2,80,159,41,42,37,248,22,144,14,247,22,185,11,11,28,23,193,2,
192,87,94,23,193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,
248,22,144,14,247,22,185,11,195,192,250,22,137,2,195,198,66,97,116,116,97,
99,104,251,211,197,198,199,10,28,192,250,22,130,9,11,196,195,248,22,128,9,
194,28,249,22,164,6,194,6,1,1,46,2,16,28,249,22,164,6,194,6,2,
2,46,46,62,117,112,192,28,249,22,165,8,248,22,67,23,200,2,23,197,1,
28,249,22,163,8,248,22,66,23,200,2,23,196,1,251,22,128,9,2,20,6,
26,26,99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,
32,126,101,58,32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65,
23,206,1,23,202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,
248,22,144,14,247,22,185,11,23,197,1,20,14,159,80,158,39,39,250,80,158,
42,40,249,22,27,11,80,158,44,39,22,152,4,23,196,1,249,247,22,189,4,
23,198,1,248,22,54,248,22,142,13,23,198,1,87,94,28,28,248,22,138,13,
23,197,2,10,248,22,176,4,23,197,2,12,28,23,198,2,250,22,130,9,11,
6,15,15,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,
250,22,131,9,2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,
111,114,32,112,97,116,104,23,199,2,28,28,248,22,63,23,197,2,249,22,163,
8,248,22,66,23,199,2,2,3,11,248,22,171,4,248,22,90,197,28,28,248,
22,63,23,197,2,249,22,163,8,248,22,66,23,199,2,66,112,108,97,110,101,
116,11,87,94,28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22,
27,11,80,158,42,39,22,185,11,23,197,1,90,161,36,35,10,249,22,153,4,
21,94,2,21,6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101,
114,46,115,115,1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,
97,109,101,45,114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94,
23,193,1,27,89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101,
99,116,105,111,110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2,
27,250,22,139,2,80,159,43,43,37,249,22,65,23,204,2,247,22,179,13,11,
28,23,193,2,192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,
159,44,48,36,248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202,
1,28,248,22,73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73,
23,199,2,9,248,22,67,23,199,2,249,22,156,13,23,195,1,28,248,22,73,
23,197,1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,181,
6,23,199,1,6,3,3,46,115,115,28,248,22,158,6,23,199,2,87,94,23,
194,1,27,248,80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43,
37,249,22,65,23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1,
91,159,37,11,90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,
1,22,156,13,23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43,
9,222,33,45,23,200,1,248,22,75,23,200,1,28,248,22,138,13,23,199,2,
87,94,23,194,1,28,248,22,161,13,23,199,2,23,198,2,248,22,75,6,26,
26,32,40,97,32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115,
111,108,117,116,101,41,28,249,22,163,8,248,22,66,23,201,2,2,21,27,250,
22,139,2,80,159,43,43,37,249,22,65,23,204,2,247,22,179,13,11,28,23,
193,2,192,87,94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45,
48,36,248,22,90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92,
23,204,2,28,248,22,73,23,194,2,249,22,190,13,0,8,35,114,120,34,91,
46,93,34,23,196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73,
248,22,92,23,208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79,
249,22,2,80,159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73,
23,196,2,248,22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204,
1,248,22,66,23,198,2,248,22,67,23,198,1,249,22,156,13,23,195,1,28,
23,198,1,87,94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23,
197,1,6,7,7,109,97,105,110,46,115,115,28,249,22,190,13,0,8,35,114,
120,34,91,46,93,34,23,199,2,23,197,1,249,22,181,6,23,199,1,6,3,
3,46,115,115,28,249,22,163,8,248,22,66,23,201,2,64,102,105,108,101,249,
22,163,13,248,22,167,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,
2,12,87,94,28,28,248,22,138,13,23,194,2,10,248,22,180,7,23,194,2,
87,94,23,200,1,12,28,23,200,2,250,22,130,9,67,114,101,113,117,105,114,
101,249,22,142,7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,
116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87,
94,23,200,1,250,22,131,9,2,20,249,22,142,7,6,13,13,109,111,100,117,
108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,
0,23,201,2,27,28,248,22,180,7,23,195,2,249,22,185,7,23,196,2,35,
249,22,165,13,248,22,166,13,23,197,2,11,27,28,248,22,180,7,23,196,2,
249,22,185,7,23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90,
161,38,35,11,28,248,22,180,7,23,199,2,250,22,7,2,22,249,22,185,7,
23,203,2,37,2,22,248,22,159,13,23,198,2,87,95,23,195,1,23,193,1,
27,28,248,22,180,7,23,200,2,249,22,185,7,23,201,2,38,249,80,158,47,
52,23,197,2,5,0,27,28,248,22,180,7,23,201,2,249,22,185,7,23,202,
2,39,248,22,171,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,
22,144,14,247,22,185,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,
123,87,94,250,22,137,2,80,159,52,42,37,248,22,144,14,247,22,185,11,195,
192,87,95,28,23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1,
12,87,95,27,27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22,
19,250,22,25,248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,
144,14,247,22,185,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,
9,226,12,11,2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159,
50,45,37,32,0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162,
43,35,50,9,227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10,
12,28,28,248,22,180,7,23,202,1,11,27,248,22,158,6,23,208,2,28,192,
192,28,248,22,63,23,208,2,249,22,163,8,248,22,66,23,210,2,2,21,11,
250,22,137,2,80,159,50,43,37,28,248,22,158,6,23,210,2,249,22,65,23,
211,1,248,80,159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211,
1,247,22,179,13,252,22,182,7,23,208,1,23,207,1,23,205,1,23,203,1,
201,12,193,91,159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38,
20,96,96,2,20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,38,
48,9,223,1,33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,87,
95,248,22,151,4,248,80,159,37,49,37,247,22,185,11,248,22,189,4,80,159,
36,36,37,248,22,176,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11,
16,0,83,158,41,20,100,143,66,35,37,98,111,111,116,29,11,11,11,11,10,
10,36,80,158,35,35,20,103,159,39,16,19,2,1,2,2,30,2,4,72,112,
97,116,104,45,115,116,114,105,110,103,63,10,30,2,4,75,112,97,116,104,45,
97,100,100,45,115,117,102,102,105,120,7,30,2,5,1,20,112,97,114,97,109,
101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,4,30,2,5,1,23,
101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,
111,110,3,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,
30,2,4,69,45,102,105,110,100,45,99,111,108,0,30,2,4,76,110,111,114,
109,97,108,45,99,97,115,101,45,112,97,116,104,6,30,2,4,79,112,97,116,
104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,9,2,15,16,0,
11,11,16,0,35,16,0,35,16,11,2,9,2,10,2,7,2,8,2,11,2,
12,2,2,2,6,2,1,2,14,2,13,46,11,11,38,35,11,11,16,1,2,
15,16,1,11,16,1,2,15,36,36,36,11,11,16,0,16,0,16,0,35,35,
11,11,11,16,0,16,0,16,0,35,35,16,0,16,16,83,158,35,16,2,89,
162,43,36,44,9,223,0,33,23,80,159,35,57,36,83,158,35,16,2,89,162,
43,36,44,9,223,0,33,24,80,159,35,56,36,83,158,35,16,2,89,162,43,
36,48,67,103,101,116,45,100,105,114,223,0,33,25,80,159,35,55,36,83,158,
35,16,2,89,162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,26,
80,159,35,54,36,83,158,35,16,2,248,22,177,7,69,115,111,45,115,117,102,
102,105,120,80,159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,2,223,
0,33,35,80,159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41,
2,6,222,192,80,159,35,41,36,83,158,35,16,2,247,22,126,80,159,35,42,
36,83,158,35,16,2,247,22,125,80,159,35,43,36,83,158,35,16,2,247,22,
61,80,159,35,44,36,83,158,35,16,2,248,22,18,74,109,111,100,117,108,101,
45,108,111,97,100,105,110,103,80,159,35,45,36,83,158,35,16,2,11,80,158,
35,46,83,158,35,16,2,11,80,158,35,47,83,158,35,16,2,32,0,89,162,
43,37,44,2,13,222,33,41,80,159,35,48,36,83,158,35,16,2,89,162,8,
44,36,44,2,14,223,0,33,50,80,159,35,49,36,83,158,35,16,2,89,162,
43,35,43,2,15,223,0,33,51,80,159,35,53,36,95,29,94,2,3,68,35,
37,107,101,114,110,101,108,11,29,94,2,3,69,35,37,109,105,110,45,115,116,
120,11,2,4,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4103);
}

9
src/mzscheme/src/env.c
View File

@ -4731,6 +4731,7 @@ local_lift_expr(int argc, Scheme_Object *argv[])
Scheme_Object *id, *local_mark, *expr, *data, *vec, *id_sym;
Scheme_Lift_Capture_Proc cp;
Scheme_Object *orig_expr;
char buf[24];
expr = argv[0];
if (!SCHEME_STXP(expr))
@ -4753,7 +4754,13 @@ local_lift_expr(int argc, Scheme_Object *argv[])
expr = scheme_add_remove_mark(expr, local_mark);
id_sym = scheme_intern_exact_parallel_symbol("lifted", 6);
/* We don't really need a new symbol each time, since the mark
will generate new bindings. But lots of things work better or faster
when different bindings have different symbols. Use env->genv->id_counter
to help keep name generation deterministic within a module. */
sprintf(buf, "lifted.%d", env->genv->id_counter++);
id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf));
id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0);
id = scheme_add_remove_mark(id, scheme_new_mark());

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