diff --git a/collects/browser/browser-sig.ss b/collects/browser/browser-sig.ss index 389d99e3cb..7ca44c34af 100644 --- a/collects/browser/browser-sig.ss +++ b/collects/browser/browser-sig.ss @@ -1,62 +1,10 @@ (module browser-sig mzscheme - (require (lib "unit.ss")) - - (provide relative-btree^ - bullet-export^ - hyper^ - html-export^ - html^) + (require (lib "unit.ss") + "private/sig.ss") - (define-signature html-export^ - (html-img-ok - html-eval-ok - image-map-snip%)) + (provide browser^) - (define-signature html^ extends html-export^ - (html-convert - html-status-handler)) - - (define-signature bullet-export^ - (bullet-size)) - - (define-signature hyper^ - (open-url - (struct exn:file-saved-instead (pathname)) - (struct exn:cancelled ()) - - hyper-text<%> - hyper-text-mixin - hyper-text% - - hyper-canvas-mixin - hyper-canvas% - - hyper-panel<%> - hyper-panel-mixin - hyper-panel% - - hyper-frame<%> - hyper-frame-mixin - hyper-frame% - - hyper-no-show-frame-mixin - hyper-no-show-frame% - - editor->page - page->editor)) - - (define-signature relative-btree^ - (make-btree - - btree-get - btree-put! - - btree-shift! - - btree-for-each - btree-map)) - - #;(define-signature browser^ + (define-signature browser^ ((open hyper^) (open html-export^) (open bullet-export^)))) diff --git a/collects/browser/browser-unit.ss b/collects/browser/browser-unit.ss index 7bf1583c4e..6fac1004c1 100644 --- a/collects/browser/browser-unit.ss +++ b/collects/browser/browser-unit.ss @@ -6,6 +6,7 @@ (lib "url-sig.ss" "net") (lib "url-unit.ss" "net") "browser-sig.ss" + "private/sig.ss" "private/bullet.ss" "private/html.ss" "private/hyper.ss") @@ -14,10 +15,24 @@ (define-unit-from-context bullet@ bullet-export^) - (define-compound-unit/infer browser@ + (define-compound-unit/infer pre-browser@ (import setup:plt-installer^ mred^ url^) (export hyper^ html-export^ bullet-export^) - (link html@ hyper@ bullet@))) + (link html@ hyper@ bullet@)) + + (define-unit/new-import-export browser@ + (import setup:plt-installer^ + mred^ + url^) + (export browser^) + ((hyper^ html-export^ bullet-export^) + pre-browser@ + setup:plt-installer^ + mred^ + url^))) + + + diff --git a/collects/browser/browser.ss b/collects/browser/browser.ss index 1d5d76658e..338a9b8fee 100644 --- a/collects/browser/browser.ss +++ b/collects/browser/browser.ss @@ -10,6 +10,6 @@ "browser-sig.ss" "browser-unit.ss") - (provide-signature-elements hyper^ html-export^ bullet-export^) + (provide-signature-elements browser^) (define-values/invoke-unit/infer browser@)) diff --git a/collects/browser/doc.txt b/collects/browser/doc.txt index 4dcfc81587..14bee0240c 100644 --- a/collects/browser/doc.txt +++ b/collects/browser/doc.txt @@ -360,8 +360,8 @@ matching the following signatures: setup:plt-installer^ mred^ - net:tcp^ (see "tcp-sig.ss" in the "net" collection) - net:url^ (see "url-sig.ss" in the "url" collection) + tcp^ (see "tcp-sig.ss" in the "net" collection) + url^ (see "url-sig.ss" in the "url" collection) It exports the browser^ signature. diff --git a/collects/browser/htmltext.ss b/collects/browser/htmltext.ss index c4549dc0b8..383e3df6f7 100644 --- a/collects/browser/htmltext.ss +++ b/collects/browser/htmltext.ss @@ -3,6 +3,7 @@ (require (lib "unit.ss") (lib "class.ss") "browser-sig.ss" + "private/sig.ss" "private/html.ss" "private/bullet.ss" (lib "url.ss" "net") diff --git a/collects/browser/private/btree.ss b/collects/browser/private/btree.ss index 53f3368180..fb486e91a9 100644 --- a/collects/browser/private/btree.ss +++ b/collects/browser/private/btree.ss @@ -1,5 +1,5 @@ (module btree (lib "a-unit.ss") - (require "../browser-sig.ss") + (require "sig.ss") ;; Implements a red-black tree with relative indexing along right ;; splines. This allows the usual O(log(n)) operations, plus a diff --git a/collects/browser/private/html.ss b/collects/browser/private/html.ss index 3549e3db34..c0350d8f09 100644 --- a/collects/browser/private/html.ss +++ b/collects/browser/private/html.ss @@ -1,5 +1,5 @@ (module html (lib "a-unit.ss") - (require "../browser-sig.ss" + (require "sig.ss" (lib "mred-sig.ss" "mred") (lib "file.ss") (lib "etc.ss") diff --git a/collects/browser/private/hyper.ss b/collects/browser/private/hyper.ss index b003830a0b..9206ebad8f 100644 --- a/collects/browser/private/hyper.ss +++ b/collects/browser/private/hyper.ss @@ -30,7 +30,7 @@ A test case: (module hyper (lib "a-unit.ss") (require (lib "class.ss") - "../browser-sig.ss" + "sig.ss" (lib "file.ss") (lib "list.ss") (lib "string.ss") diff --git a/collects/compiler/doc.txt b/collects/compiler/doc.txt index a2c8922645..d849698a93 100644 --- a/collects/compiler/doc.txt +++ b/collects/compiler/doc.txt @@ -249,8 +249,9 @@ _option.ss_ module. Options are set by the following parameters: > propagate-constants - #t improves the code by propagating constants. Default = #t. -> assume-primitives - #t equates X with #%X when - #%X exists. This is useful only with non-unitized code. +> assume-primitives - #t adds `(require mzscheme)' + to the beginning of the program. This is useful only + with non-`module' code. Default = #f. > stupid - Allow obvious non-syntactic errors; e.g.: @@ -259,7 +260,7 @@ _option.ss_ module. Options are set by the following parameters: > vehicles - Controls how closures are compiled. The possible values are: 'vehicles:automatic - auto-groups 'vehicles:functions - groups by procedure - 'vehicles:units - groups by unit + 'vehicles:units - usupported 'vehicles:monolithic - groups randomly Default = 'vehicles:automatic. @@ -287,7 +288,7 @@ the `dynext' collection . Those options control the actual C compiler and linker that are used. See doc.txt in the `dynext' collection for more information about those options. -The _option-unit.ss_ library is a unit/sig matching the signature +The _option-unit.ss_ library is a unit exporting the signature > compiler:option^ which contains these options. The _sig.ss_ library defines the `compiler:option^' signature. @@ -297,9 +298,9 @@ which contains these options. The _sig.ss_ library defines the The Compiler as a Unit ====================== -The _compiler-unit.ss_ library provides a unit/sig +The _compiler-unit.ss_ library provides a unit > compiler@ -matching the signature +exporting the signature > compiler^ which provides the compiler.ss functions. This signature and all auxiliary signatures needed by compiler@ are defined by the @@ -320,7 +321,7 @@ Low-level Extension Compiler and Linker The high-level compiler.ss interface relies on low-level implementations of the extension compiler and linker. -The _comp-unit.ss_ and _ld-unit.ss_ libraries define unit/sigs for the +The _comp-unit.ss_ and _ld-unit.ss_ libraries define units for the low-level extension compiler and multi-file linker, > ld@ and @@ -359,7 +360,7 @@ The low-level linker functions from ld@ are: compiled object and .kp files into a multi-file extension. -Both unit/sigs requires the following imports: +Both units require the following imports: dynext:compile^ - From the `dynext' collection dynext:link^ @@ -390,7 +391,7 @@ prints the bundle to the current output port, instead; this stream can be `load'ed directly by a running program, as long as the `read-accept-compiled' parameter is true. -The _embedr-unit.ss_ library provides a signed unit, _compiler:embed@_ +The _embedr-unit.ss_ library provides a unit, _compiler:embed@_ that imports nothing and exports the functions below. The _embedr-sig.ss_ library provides the signature, _compiler:embed^_. diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 584e5821a9..1cab9f0cd0 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -51,7 +51,7 @@ ; e.g.: ((lambda () 0) 1 2 3) vehicles ; Controls how closures are compiled: - ; 'vehicles:automatic, + ; 'vehicles:automatic, ; 'vehicles:functions, ; 'vechicles:units, or ; 'vehicles:monolithic. diff --git a/collects/dynext/doc.txt b/collects/dynext/doc.txt index 0335c6407e..34b5c1cc54 100644 --- a/collects/dynext/doc.txt +++ b/collects/dynext/doc.txt @@ -88,8 +88,8 @@ Under MacOS, none of these options are used. The compiler always uses CodeWarrior if it can be found and the compilation options cannot be changed. -The unit/sig form defined by _compiler.ss_ (signature in -_compiles.ss_) requires no imports. +The unit form _dynext:compile@_ from _compile-unit.ss_ requires no +imports and exports _dynext:compile^_ from _compile-sig.ss_. _link.ss_ --------- @@ -162,8 +162,8 @@ Under MacOS, none of these options are used. The linker always uses CodeWarrior if it can be found and the linking options cannot be changed. -The unit/sig form defined by _linkr.ss_ (signature in _links.ss_) -requires no imports. +The unit form _dynext:link@_ from _link-unit.ss_ requires no +imports and exports _dynext:link^_ from _link-sig.ss_. _file.ss_ --------- @@ -201,5 +201,5 @@ _file.ss_ > (extract-base-filename/ext s program) - same as extract-base-filename/ss, but for extension files. -The unit/sig defined by _filer.ss_ (signature in _files.ss_) requires -no imports. +The unit form _dynext:file@_ from _file-unit.ss_ requires no +imports and exports _dynext:file^_ from _file-sig.ss_. diff --git a/collects/errortrace/doc.txt b/collects/errortrace/doc.txt index 36be354b87..2a97da5afa 100644 --- a/collects/errortrace/doc.txt +++ b/collects/errortrace/doc.txt @@ -242,7 +242,7 @@ _Re-using errortrace stack tracing_ ----------------------------------- The errortrace collection also includes a _stacktrace.ss_ library. It -exports the _stacktrace@_ unit and it import signature +exports the _stacktrace@_ unit, its import signature _stacktrace-imports^_, and its export signature _stacktrace^_. The export signature contains these names: diff --git a/collects/games/aces/aces.scm b/collects/games/aces/aces.scm index a3b3131424..c7ce210b11 100644 --- a/collects/games/aces/aces.scm +++ b/collects/games/aces/aces.scm @@ -9,15 +9,15 @@ possible to remap single click (instead of double click)? (require (lib "cards.ss" "games" "cards") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "mred.ss" "mred") (lib "list.ss") (lib "string-constant.ss" "string-constants") "../show-help.ss") - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/blackjack/blackjack.ss b/collects/games/blackjack/blackjack.ss index e5bd906bba..88d0de4d1c 100644 --- a/collects/games/blackjack/blackjack.ss +++ b/collects/games/blackjack/blackjack.ss @@ -33,12 +33,12 @@ (require (lib "cards.ss" "games" "cards") (lib "mred.ss" "mred") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "list.ss")) - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/checkers/checkers.ss b/collects/games/checkers/checkers.ss index f618c9b2f3..0b062c6c03 100644 --- a/collects/games/checkers/checkers.ss +++ b/collects/games/checkers/checkers.ss @@ -7,11 +7,11 @@ (prefix gl- (lib "sgl.ss" "sgl")) (lib "gl.ss" "sgl") (lib "array.ss" "srfi" "25") - (lib "unit200.ss") + (lib "unit.ss") (lib "include-bitmap.ss" "mrlib") "honu-bitmaps.ss") - (provide game-unit) + (provide game@) (define-struct image (width height rgba)) @@ -65,10 +65,14 @@ (define-struct piece-info (x y color king?) (make-inspector)) (define-struct moves (list forced-jump?)) - (define checkers-view@ - (unit - (import move) - (export add-space add-piece remove-piece move-piece set-turn show) + (define-signature model^ + (move)) + (define-signature view^ + (add-space add-piece remove-piece move-piece set-turn show)) + + (define-unit view@ + (import model^) + (export view^) (define (get-space-draw-fn space) (let* ((list-id (get-square-dl (space-info-light? space) @@ -298,12 +302,11 @@ (getter (if light? light-square dark-square)))) (define (show) - (send f show #t)))) + (send f show #t))) - (define checkers-model@ - (unit - (import add-space add-piece remove-piece move-piece set-turn) - (export move) + (define-unit model@ + (import view^) + (export model^) (define turn 'red) (define board (make-array (shape 0 8 0 8) #f)) @@ -467,14 +470,16 @@ (set-turn turn (get-moves)))))))))) (set-turn turn (get-moves)) - )) + ) + + (define-unit show@ + (import view^) + (export) + (show)) - (define game-unit - (compound-unit + (define game@ + (compound-unit/infer (import) - (link - (VIEW (checkers-view@ (MODEL move))) - (MODEL (checkers-model@ (VIEW add-space add-piece remove-piece move-piece set-turn))) - (SHOW ((unit (import show) (export) (show)) (VIEW show)))) - (export))) + (export) + (link view@ model@ show@))) ) diff --git a/collects/games/crazy8s/crazy8s.ss b/collects/games/crazy8s/crazy8s.ss index 2410c7d2e8..d8288d4017 100644 --- a/collects/games/crazy8s/crazy8s.ss +++ b/collects/games/crazy8s/crazy8s.ss @@ -3,7 +3,7 @@ (require (lib "cards.ss" "games" "cards") (lib "mred.ss" "mred") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "etc.ss") (lib "list.ss") (lib "async-channel.ss") @@ -34,10 +34,16 @@ (define SEL-WIDTH 32) (define SEL-HEIGHT 32) - (provide game-unit) + (provide game@) + + (define-signature configuration^ + (opponents-count + init-hand-size + drag-mode? + new-game)) ;; This unit drives multiple Crazy 8 instances: - (define game-unit + (define game@ (unit (import) (export) @@ -62,19 +68,15 @@ (parameterize ([current-eventspace (make-eventspace)]) (queue-callback (lambda () - (invoke-unit configured-game-unit - opponents-count - init-hand-size - drag-mode? - new-game))))))) + (invoke-unit configured-game@ (import configuration^)))))))) ;; Start the initial child game: (start-new-game opponents-count init-hand-size drag-mode?))) ;; This unit is for a particular Crazy 8 instance: - (define configured-game-unit + (define configured-game@ (unit - (import opponents-count init-hand-size drag-mode? new-game) + (import configuration^) (export) ;; Randomize diff --git a/collects/games/doc.txt b/collects/games/doc.txt index 8b33b25d9d..562848827f 100644 --- a/collects/games/doc.txt +++ b/collects/games/doc.txt @@ -92,10 +92,10 @@ collection. If a sub-collection has an info.ss definition (see the mzc manual), the following fields of the collection's "info.ss" file are used: - * `game' [required] : used as a library name in the sub-collection to - load for the game; the library must export a `game-unit' unsigned - unit (see MzLib's `unit' form); the unit is invoked with no - imports to start the game. + * `game' [required] : used as a module name in the sub-collection to + load for the game; the module must provide a `game@' unit (see + MzLib's "unit.ss" form) with no particular exports; the unit is + invoked with no imports to start the game. * `name' [defaults to the collection name] : used to label the game-starting button in the game console. diff --git a/collects/games/games.ss b/collects/games/games.ss index e37ea987d5..cee8a5c8f3 100644 --- a/collects/games/games.ss +++ b/collects/games/games.ss @@ -1,7 +1,7 @@ (module games mzscheme (require (lib "mred.ss" "mred") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "list.ss") (lib "getinfo.ss" "setup") (lib "bitmap-label.ss" "mrlib") @@ -51,10 +51,10 @@ p) p (lambda (b e) - (let ([game-unit (dynamic-wind - begin-busy-cursor - (lambda () (dynamic-require (build-path dir file) 'game-unit)) - end-busy-cursor)]) + (let ([game@ (dynamic-wind + begin-busy-cursor + (lambda () (dynamic-require (build-path dir file) 'game@)) + end-busy-cursor)]) (let ([c (make-custodian)]) (parameterize ([current-custodian c]) (parameterize ([current-eventspace (make-eventspace)]) @@ -62,7 +62,7 @@ (lambda () (exit-handler (lambda (v) (custodian-shutdown-all c))) - (invoke-unit game-unit)))))))))))) + (invoke-unit game@)))))))))))) (let ([game-mapping (sort game-mapping (lambda (a b) diff --git a/collects/games/gcalc/gcalc.ss b/collects/games/gcalc/gcalc.ss index e9f3c370bd..9178d4df94 100644 --- a/collects/games/gcalc/gcalc.ss +++ b/collects/games/gcalc/gcalc.ss @@ -5,8 +5,8 @@ (module gcalc mzscheme (require (lib "class.ss") (lib "mred.ss" "mred") (lib "etc.ss") - "../show-help.ss" (lib "unit200.ss")) - (provide game-unit) + "../show-help.ss" (lib "unit.ss")) + (provide game@) (define customs '()) (define (add-custom! name get set type desc) @@ -19,7 +19,7 @@ (begin (define var default) (add-custom! 'var (lambda () var) (lambda (v) (set! var v)) type description))])) - (define game-unit + (define game@ (unit (import) (export) ;;;============================================================================ diff --git a/collects/games/ginrummy/ginrummy.ss b/collects/games/ginrummy/ginrummy.ss index 481e83d03c..e157eb5db0 100644 --- a/collects/games/ginrummy/ginrummy.ss +++ b/collects/games/ginrummy/ginrummy.ss @@ -3,12 +3,12 @@ (require (lib "cards.ss" "games" "cards") (lib "mred.ss" "mred") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "list.ss")) - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/gobblet/gobblet.ss b/collects/games/gobblet/gobblet.ss index b7a56654bf..dad97ffcb6 100644 --- a/collects/games/gobblet/gobblet.ss +++ b/collects/games/gobblet/gobblet.ss @@ -1,6 +1,6 @@ (module gobblet mzscheme (require (lib "unitsig.ss") - (lib "unit200.ss") + (only (lib "unit.ss") unit import export) (lib "file.ss") (lib "mred.ss" "mred") "sig.ss" @@ -10,9 +10,9 @@ "explore.ss" "../show-help.ss") - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/gofish/gofish.ss b/collects/games/gofish/gofish.ss index f9f086a3df..49cfb6b7f7 100644 --- a/collects/games/gofish/gofish.ss +++ b/collects/games/gofish/gofish.ss @@ -3,12 +3,12 @@ (require (lib "cards.ss" "games" "cards") (lib "mred.ss" "mred") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "list.ss")) - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/jewel/jewel.scm b/collects/games/jewel/jewel.scm index 91c20cf44d..0e83733851 100644 --- a/collects/games/jewel/jewel.scm +++ b/collects/games/jewel/jewel.scm @@ -3,7 +3,7 @@ (module jewel mzscheme - (require (lib "unit200.ss") + (require (lib "unit.ss") (lib "string.ss") (lib "class.ss") (lib "file.ss") @@ -17,10 +17,10 @@ "../show-help.ss" ) - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/lights-out/lights-out.ss b/collects/games/lights-out/lights-out.ss index 612d3ceb76..b067fac565 100644 --- a/collects/games/lights-out/lights-out.ss +++ b/collects/games/lights-out/lights-out.ss @@ -3,14 +3,18 @@ "../show-help.ss" (lib "mred.ss" "mred") (lib "class.ss") - (lib "unit200.ss")) + (lib "unit.ss")) - (provide game-unit) + (provide game@ + lights-out^) - (define game-unit + (define-signature lights-out^ + (init-board)) + + (define game@ (unit (import) - (export init-board) ;; : (board -> void) resets the window(s) + (export lights-out^) ;; : (board -> void) resets the window(s) (define frame (make-object frame% "Lights Out")) diff --git a/collects/games/memory/memory.ss b/collects/games/memory/memory.ss index 8380b8bba2..a034565468 100644 --- a/collects/games/memory/memory.ss +++ b/collects/games/memory/memory.ss @@ -3,12 +3,12 @@ (require (lib "cards.ss" "games" "cards") (lib "mred.ss" "mred") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "list.ss")) - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/mines/mines.ss b/collects/games/mines/mines.ss index 27717ff4cd..1744f989c0 100644 --- a/collects/games/mines/mines.ss +++ b/collects/games/mines/mines.ss @@ -1,23 +1,25 @@ ;; An example implementation of the ever-popular Minesweeper game. -;; The graphics are primitive, but the event-handling is general. For -;; example, clicking on a tile hilites the tile, but moving the mouse -;; off the tile before releasing the mouse button unhilites the tile -;; and ignores the click. - ;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;; (module mines mzscheme (require (lib "etc.ss") ; defines build-vector (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "mred.ss" "mred") (lib "include-bitmap.ss" "mrlib")) - (provide game-unit) + (provide game@) + ;; Layout constants + (define TILE-HW 24) ; height/width of a tile + (define B-WIDTH 16) ; number of tiles across + (define B-HEIGHT 16) ; number of tiles down + (define THE-BOMB-COUNT 30) ; number of bombs to hide + + ;; Bitmap constants (define tile-bm (include-bitmap "images/tile.png")) (define lclick-bm (include-bitmap "images/lclick-tile.png")) (define rclick-bm (include-bitmap "images/rclick-tile.png")) @@ -26,42 +28,37 @@ (define bomb-bm (include-bitmap "images/bomb.png")) (define explode-bm (include-bitmap "images/explode.png")) (define flag-bm (include-bitmap "images/flag.png")) + + (define DIGIT-COLOR-NAMES + ;; 0th is background; 8th is foreground + (vector "WHITE" "BLUE" "FORESTGREEN" "RED" "PURPLE" + "ORANGE" "YELLOW" "BROWN" "BLACK")) - ;; The game is implemented in a unit so it can be started multiple times - (define game-unit + (define DIGIT-COLORS + (build-vector 9 (lambda (i) + (send the-color-database find-color + (vector-ref DIGIT-COLOR-NAMES i))))) + + (define BG-COLOR (vector-ref DIGIT-COLORS 0)) + (define FG-COLOR (vector-ref DIGIT-COLORS 8)) + + (define BLACK-COLOR (send the-color-database find-color "BLACK")) + + (define BG-PEN (make-object pen% BG-COLOR 1 'solid)) + (define FG-PEN (make-object pen% FG-COLOR 1 'solid)) + + ;; A function for looping over numbers: + (define (step-while first test until f accum init) + (let loop ([n first][a init]) + (if (test n until) + (loop (add1 n) (accum a (f n))) + a))) + + ;; The rest of the game is implemented in a unit so it can be started multiple times + (define game@ (unit (import) (export) - - (define TILE-HW 24) ; height/width of a tile - (define B-WIDTH 16) ; number of tiles across - (define B-HEIGHT 16) ; number of tiles down - (define THE-BOMB-COUNT 30) ; number of bombs to hide - - (define DIGIT-COLOR-NAMES - ;; 0th is background; 8th is foreground - (vector "WHITE" "BLUE" "FORESTGREEN" "RED" "PURPLE" - "ORANGE" "YELLOW" "BROWN" "BLACK")) - - (define DIGIT-COLORS - (build-vector 9 (lambda (i) - (send the-color-database find-color - (vector-ref DIGIT-COLOR-NAMES i))))) - - (define BG-COLOR (vector-ref DIGIT-COLORS 0)) - (define FG-COLOR (vector-ref DIGIT-COLORS 8)) - - (define BLACK-COLOR (send the-color-database find-color "BLACK")) - - (define BG-PEN (make-object pen% BG-COLOR 1 'solid)) - (define FG-PEN (make-object pen% FG-COLOR 1 'solid)) - - ;; A general function for looping over numbers: - (define (step-while first test until f accum init) - (let loop ([n first][a init]) - (if (test n until) - (loop (add1 n) (accum a (f n))) - a))) ;; ;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;; diff --git a/collects/games/paint-by-numbers/paint-by-numbers.ss b/collects/games/paint-by-numbers/paint-by-numbers.ss index d75aa0c4e3..0ecf57b317 100644 --- a/collects/games/paint-by-numbers/paint-by-numbers.ss +++ b/collects/games/paint-by-numbers/paint-by-numbers.ss @@ -7,12 +7,12 @@ "../show-help.ss" (lib "framework.ss" "framework") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "pretty.ss") (lib "list.ss") (lib "mred.ss" "mred")) - (provide game-unit) + (provide game@) (define default-font (send the-font-list find-or-create-font 10 'roman 'normal 'normal #f)) (preferences:set-default 'paint-by-numbers:font default-font (lambda (f) (is-a? f font%))) @@ -509,7 +509,7 @@ (send (send f get-canvas) set-grid state) (send f show #t))])) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/parcheesi/parcheesi.ss b/collects/games/parcheesi/parcheesi.ss index 4d4ff4a287..94259583ef 100644 --- a/collects/games/parcheesi/parcheesi.ss +++ b/collects/games/parcheesi/parcheesi.ss @@ -1,11 +1,13 @@ (module parcheesi mzscheme - (require (lib "unit200.ss") - (lib "class.ss")) + (require (lib "unit.ss") + (lib "class.ss") + "admin-gui.ss") - (provide game-unit) - (define game-unit + (provide game@) + (define game@ (unit (import) (export) - (new (dynamic-require '(lib "admin-gui.ss" "games" "parcheesi") 'gui-game%))))) + (new gui-game%)))) + diff --git a/collects/games/pousse/pousse.ss b/collects/games/pousse/pousse.ss index 31a25d4b11..72248e3a70 100644 --- a/collects/games/pousse/pousse.ss +++ b/collects/games/pousse/pousse.ss @@ -4,13 +4,13 @@ "board-size.ss" (lib "class.ss") (lib "class100.ss") - (lib "unit200.ss") + (all-except (lib "unit.ss") rename) ; rename collides with class100 (lib "mred.ss" "mred") (prefix robot: "robot.ss")) - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/same/same.ss b/collects/games/same/same.ss index 24cd52f7fe..baab14e0a9 100644 --- a/collects/games/same/same.ss +++ b/collects/games/same/same.ss @@ -1,14 +1,14 @@ (module same mzscheme (require (lib "etc.ss") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "mred.ss" "mred") (lib "list.ss") "../show-help.ss") - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/slidey/slidey.ss b/collects/games/slidey/slidey.ss index 238632a9fe..e581ce96a5 100644 --- a/collects/games/slidey/slidey.ss +++ b/collects/games/slidey/slidey.ss @@ -2,12 +2,12 @@ (module slidey mzscheme (require (lib "etc.ss") (lib "class.ss") - (lib "unit200.ss") + (lib "unit.ss") (lib "mred.ss" "mred")) - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/games/spider/spider.ss b/collects/games/spider/spider.ss index cd84ace5cd..c0bbbf76cf 100644 --- a/collects/games/spider/spider.ss +++ b/collects/games/spider/spider.ss @@ -6,7 +6,7 @@ (lib "mred.ss" "mred") (lib "list.ss") (lib "file.ss") - (lib "unit200.ss") + (lib "unit.ss") "../show-help.ss") (define (list-first-n l n) @@ -16,9 +16,9 @@ (define (vector-copy v) (list->vector (vector->list v))) - (provide game-unit) + (provide game@) - (define game-unit + (define game@ (unit (import) (export) diff --git a/collects/help/private/gui.ss b/collects/help/private/gui.ss index 21db3922aa..af3252967b 100644 --- a/collects/help/private/gui.ss +++ b/collects/help/private/gui.ss @@ -11,7 +11,7 @@ (lib "string-constant.ss" "string-constants") (lib "external.ss" "browser") - (prefix browser: (lib "browser-sig.ss" "browser")) + (lib "browser-sig.ss" "browser") (lib "url-sig.ss" "net") (lib "url-structs.ss" "net") (lib "uri-codec.ss" "net") @@ -26,7 +26,7 @@ "internal-hp.ss") - (import browser:hyper^ browser:html-export^ browser:bullet-export^ url^) + (import browser^ url^) (export gui^) (define help-desk-frame<%> diff --git a/collects/hierlist/doc.txt b/collects/hierlist/doc.txt index cb8fb8ffb2..da0a04ae67 100644 --- a/collects/hierlist/doc.txt +++ b/collects/hierlist/doc.txt @@ -1,12 +1,9 @@ _Hierarchical List Control_ -hierlists.ss defines hierlist^ -hierlistr.ss returns a unit/sig, imports mred^ and -mzlib:function^ and exports hierlist^ -hierlist.ss invoke-opens hierlistr.ss - -_hierlist_ defines three classes: +hierlist.ss provides the classes and interfaces described below. +hierlist-sig.ss provides hierlist^, which includes the same classes and interfaces. +hierlist-unit.ss provide a unit that imports mred^ and exports hierlist^. -------------------------------------------------- diff --git a/collects/lang/doc.txt b/collects/lang/doc.txt index 701182a03c..32a170a8c1 100644 --- a/collects/lang/doc.txt +++ b/collects/lang/doc.txt @@ -8,7 +8,7 @@ languages for other modules (i.e., as the initial import): * _plt-pretty-big-text.ss_ - provides MzScheme plus the following MzLib libraries: etc.ss, file.ss, list.ss, - class.ss, unit.ss, unitsig.ss, include.ss, defmacro.ss, + class.ss, unit.ss, include.ss, defmacro.ss, pretty.ss, string.ss, thread.ss, math.ss, match.ss, and shared.ss. It also provides the posn, color, and image functions of Beginning Student. diff --git a/collects/lang/plt-pretty-big-text.ss b/collects/lang/plt-pretty-big-text.ss index b00f7a0d5a..7bc1a7a976 100644 --- a/collects/lang/plt-pretty-big-text.ss +++ b/collects/lang/plt-pretty-big-text.ss @@ -4,8 +4,7 @@ (lib "file.ss") (lib "list.ss") (lib "class.ss") - (lib "unit200.ss") - (lib "unitsig.ss") + (lib "unit.ss") (lib "include.ss") (lib "defmacro.ss") (lib "pretty.ss") @@ -21,8 +20,7 @@ (all-from (lib "file.ss")) (all-from (lib "list.ss")) (all-from (lib "class.ss")) - (all-from (lib "unit200.ss")) - (all-from (lib "unitsig.ss")) + (all-from (lib "unit.ss")) (all-from (lib "include.ss")) (all-from (lib "defmacro.ss")) (all-from (lib "pretty.ss")) diff --git a/collects/launcher/doc.txt b/collects/launcher/doc.txt index 4a8c9cb48a..67bfe13786 100644 --- a/collects/launcher/doc.txt +++ b/collects/launcher/doc.txt @@ -1,8 +1,12 @@ -The _launcherr.ss_ library in the "launcher" collection imports -mzlib:file^, dynext:compile^, and dynext:link^, and exports the -following procedures for creating MzScheme and MrEd launcher -executables. +The _launcher.ss_ library in the "launcher" collection provides the +following procedures. + +The _launcher-sig.ss_ library provides `launcher^', which includes +the same procedures. + +The _launcher-unit.ss_ library provides `launcher@', which imports +`dynext:compile^' and `dynext:link^', and exports `launcher^'. ===== Launcher creation ======================================== diff --git a/collects/make/doc.txt b/collects/make/doc.txt index 865f7b5867..8bd816bda4 100644 --- a/collects/make/doc.txt +++ b/collects/make/doc.txt @@ -118,9 +118,6 @@ The `target' field is a string or a list of strings naming the target(s), and the `orig-exn' field is the original exception. -The maker.ss library is a signed unit that requires no -imports and provides `make/proc'. - make.ss also provides the following parameters: > (make-print-checking [on?]) - If #f, make only prints when @@ -134,6 +131,12 @@ corresponding make line. Default: #f. > (make-print-reasons [on?]) If #t, make prints the reason for each dependency that fires. Default: #t. +The make-sig.ss library provides `make^' signature that includes all +of the above. + +The make-unit.ss library provides a `make@' unit with no imports and the +single export `make^'. + _collection.ss_ --------------- diff --git a/collects/mzlib/private/match/match-helper.ss b/collects/mzlib/private/match/match-helper.ss index 58eadf9c67..1ec286ed98 100644 --- a/collects/mzlib/private/match/match-helper.ss +++ b/collects/mzlib/private/match/match-helper.ss @@ -8,8 +8,6 @@ "match-error.ss" (lib "list.ss")) - (require (only (lib "1.ss" "srfi") zip unzip2)) - (require-for-template mzscheme) ;; define a syntax-transformer in terms of a two-argument function @@ -77,8 +75,9 @@ ;; we only filter out a mutator if the accessor is also false. ;; this function returns 2 lists of the same length if the inputs were the same length (define (handle-acc/mut-lists accs muts) - (let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (zip accs muts))] - [(accs muts) (unzip2 filtered-lists)]) + (let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (map list accs muts))] + [(accs muts) (values (map car filtered-lists) + (map cadr filtered-lists))]) (values (reverse accs) (reverse muts)))) diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss index da9ce4d084..deeb5bec1b 100644 --- a/collects/mzlib/private/match/render-test-list-impl.ss +++ b/collects/mzlib/private/match/render-test-list-impl.ss @@ -1,7 +1,6 @@ (module render-test-list-impl mzscheme (require (lib "stx.ss" "syntax")) - (require (rename (lib "1.ss" "srfi") map-append append-map)) (require "match-error.ss" "match-helper.ss" @@ -226,8 +225,10 @@ ((app op pat) (render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx)) - [(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx)) - (syntax->list #'pats))] + [(and . pats) (apply + append + (map (lambda (pat) (render-test-list pat ae cert stx)) + (syntax->list #'pats)))] ((or . pats) (list (make-act @@ -372,24 +373,26 @@ ,(map syntax-object->datum parental-chain) ,ae-datum) ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp))) - (map-append - (lambda (cur-pat cur-mutator cur-accessor) - (syntax-case cur-pat (set! get!) - [(set! . rest) - (unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields")) - (set/get-matcher 'set! ae p #'rest - #`(lambda (y) - (#,cur-mutator #,ae y)))] - [(get! . rest) - (set/get-matcher 'get! ae p #'rest - #`(lambda () - (#,cur-accessor #,ae)))] - [_ (render-test-list - cur-pat - (quasisyntax/loc cur-pat (#,cur-accessor #,ae)) - cert - stx)])) - field-pats mutators accessors)))) + (apply + append + (map + (lambda (cur-pat cur-mutator cur-accessor) + (syntax-case cur-pat (set! get!) + [(set! . rest) + (unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields")) + (set/get-matcher 'set! ae p #'rest + #`(lambda (y) + (#,cur-mutator #,ae y)))] + [(get! . rest) + (set/get-matcher 'get! ae p #'rest + #`(lambda () + (#,cur-accessor #,ae)))] + [_ (render-test-list + cur-pat + (quasisyntax/loc cur-pat (#,cur-accessor #,ae)) + cert + stx)])) + field-pats mutators accessors))))) ;; syntax checking ((struct ident ...) diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss index fac49fa7d7..504aa65bf3 100644 --- a/collects/mzlib/private/match/simplify-patterns.ss +++ b/collects/mzlib/private/match/simplify-patterns.ss @@ -1,7 +1,6 @@ (module simplify-patterns mzscheme (require (lib "stx.ss" "syntax")) - (require (rename (lib "1.ss" "srfi") map-append append-map)) (require "match-error.ss" "match-helper.ss" @@ -14,8 +13,7 @@ "render-helpers.ss" "observe-step.ss") - (require "render-sigs.ss" - (lib "unitsig.ss")) + (require "render-sigs.ss") (require-for-syntax "match-helper.ss" "match-expander-struct.ss" diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index f5e201c120..a119b05676 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -206,12 +206,12 @@ ((((vid ...) . vbody) ...) all-val-defs) ((((sid ...) . sbody) ...) all-stx-defs)) #`(begin - (define x (gensym)) + (define signature-tag (gensym)) (define-syntax #,sigid (make-set!-transformer (make-signature (make-siginfo (list #'#,sigid #'super-name ...) - (list ((syntax-local-certifier) (quote-syntax x)) + (list ((syntax-local-certifier) (quote-syntax signature-tag)) #'super-rtime ...)) (list (quote-syntax var) ...) @@ -294,12 +294,26 @@ (define-for-syntax (signature->identifiers sigids) (define provide-tagged-sigs (map process-tagged-import sigids)) (define provide-sigs (map caddr provide-tagged-sigs)) - (apply append (map sig-int-names provide-sigs))) + (map sig-int-names provide-sigs)) (define-syntax/err-param (provide-signature-elements stx) (syntax-case stx () ((_ . p) - (let* ((names (signature->identifiers (checked-syntax->list #'p))) + (let* ((sigs (checked-syntax->list #'p)) + (nameses (signature->identifiers sigs)) + ;; Export only the names that would be visible to uses + ;; with the same lexical context as p. Otherwise, we + ;; can end up with collisions with renamings that are + ;; symbolically the same, such as those introduced by + ;; `open'. + (nameses (map (lambda (sig names) + (filter (lambda (name) + (bound-identifier=? + name + (datum->syntax-object sig (syntax-e name)))) + names)) + sigs nameses)) + (names (apply append nameses)) (dup (check-duplicate-identifier names))) (when dup (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) diff --git a/collects/net/doc.txt b/collects/net/doc.txt index 1a9ac805d5..86735b0256 100644 --- a/collects/net/doc.txt +++ b/collects/net/doc.txt @@ -17,8 +17,8 @@ _URL_ posting, _web clients_, _WWW_ To load directly: (require (lib "url.ss" "net")) Module files: _url.ss_ - provides the procedures documented below - _url-unit.ss_ - provides unit net:url@ - _url-sig.ss_ - provides signature net:url^ + _url-unit.ss_ - provides unit url@ + _url-sig.ss_ - provides signature url^ _url-struct.ss_ - provides the url and path/param structs @@ -234,10 +234,10 @@ EXAMPLE -------------------------------------------------------------- UNITS ---------------------------------------------------------------- -The _url-sig.ss_ module exports the _net:url^_ signature which +The _url-sig.ss_ module exports the _url^_ signature which contains the names documented above. the _url-unit.ss_ module exports -_url@_, a unit that imports net:tcp^ (see "tcp-sig.ss", below) and -exports the names in net:url^. +_url@_, a unit that imports tcp^ (see "tcp-sig.ss", below) and +exports the names in url^. ========================================================================== _URL viewing_ @@ -287,8 +287,8 @@ _CGI_ backends, _WWW_ To load directly: (require (lib "cgi.ss" "net")) Module files: _cgi.ss_ - provides the procedures documented below - _cgi-unit.ss_ - provides unit net:cgi@ - _cgi-sig.ss_ - provides signature net:cgi^ + _cgi-unit.ss_ - provides unit cgi@ + _cgi-sig.ss_ - provides signature cgi^ ABSTRACT ------------------------------------------------------------- @@ -416,8 +416,8 @@ _sending mail_, _sendmail_ To load directly: (require (lib "sendmail.ss" "net")) Module files: _sendmail.ss_ - provides the procedures documented below - _sendmail-unit.ss_ - provides unit net:sendmail@ - _sendmail-sig.ss_ - provides signature net:sendmail^ + _sendmail-unit.ss_ - provides unit sendmail@ + _sendmail-sig.ss_ - provides signature sendmail^ ABSTRACT ------------------------------------------------------------- @@ -472,8 +472,8 @@ _sending mail_, _SMTP_ To load directly: (require (lib "smtp.ss" "net")) Module files: _smtp.ss_ - provides the procedures documented below - _smtp-unit.ss_ - provides unit net:smtp@ - _smtp-sig.ss_ - provides signature net:smtp^ + _smtp-unit.ss_ - provides unit smtp@ + _smtp-sig.ss_ - provides signature smtp^ ABSTRACT ------------------------------------------------------------- @@ -548,8 +548,8 @@ _NNTP_, _newsgroups_ To load directly: (require (lib "nntp.ss" "net")) Module files: _nntp.ss_ - provides the procedures documented below - _nntp-unit.ss_ - provides unit net:nntp@ - _nntp-sig.ss_ - provides signature net:nntp^ + _nntp-unit.ss_ - provides unit nntp@ + _nntp-sig.ss_ - provides signature nntp^ ABSTRACT ------------------------------------------------------------- @@ -695,8 +695,8 @@ _POP-3_, _reading mail_ To load directly: (require (lib "pop3.ss" "net")) Module files: _pop3.ss_ - provides the procedures documented below - _pop3-unit.ss_ - provides unit net:pop3@ - _pop3-sig.ss_ - provides signature net:pop3^ + _pop3-unit.ss_ - provides unit pop3@ + _pop3-sig.ss_ - provides signature pop3^ ABSTRACT ------------------------------------------------------------- @@ -874,8 +874,8 @@ _IMAP_, _reading mail_ To load directly: (require (lib "imap.ss" "net")) Module files: _imap.ss_ - provides the procedures documented below - _imap-unit.ss_ - provides unit net:imap@ - _imap-sig.ss_ - provides signature net:imap^ + _imap-unit.ss_ - provides unit imap@ + _imap-sig.ss_ - provides signature imap^ ABSTRACT ------------------------------------------------------------- @@ -1249,8 +1249,8 @@ _mime headers_, _mail headers_, _http headers_ To load directly: (require (lib "head.ss" "net")) Module files: _head.ss_ - provides the procedures documented below - _head-unit.ss_ - provides unit net:head@ - _head-sig.ss_ - provides signature net:head^ + _head-unit.ss_ - provides unit head@ + _head-sig.ss_ - provides signature head^ ABSTRACT ------------------------------------------------------------- @@ -1400,8 +1400,8 @@ _DNS_, _domain name service_ To load directly: (require (lib "dns.ss" "net")) Module files: _dns.ss_ - provides the procedures documented below - _dns-unit.ss_ - provides unit net:dns@ - _dns-sig.ss_ - provides signature net:dns^ + _dns-unit.ss_ - provides unit dns@ + _dns-sig.ss_ - provides signature dns^ ABSTRACT ------------------------------------------------------------- @@ -1446,10 +1446,10 @@ _MIME support__ To load directly: (require (lib "mime.ss" "net")) Module files: _mime.ss_ - provides the procedures documented below - _mime-unit.ss_ - provides unit net:mime@ - imports net:base64^ from "base64-sig.ss" - and net:qp^ from "qp-sig.ss" - _mime-sig.ss_ - provides signature net:mime^ + _mime-unit.ss_ - provides unit mime@ + imports base64^ from "base64-sig.ss" + and qp^ from "qp-sig.ss" + _mime-sig.ss_ - provides signature mime^ ABSTRACT ------------------------------------------------------------- @@ -1758,8 +1758,8 @@ _Base 64 Encoding_, _base64_ To load directly: (require (lib "base64.ss" "net")) Module files: _base64.ss_ - provides the procedures documented below - _base64-unit.ss_ - provides unit net:base64@ - _base64-sig.ss_ - provides signature net:base64^ + _base64-unit.ss_ - provides unit base64@ + _base64-sig.ss_ - provides signature base64^ ABSTRACT ------------------------------------------------------------- @@ -1800,8 +1800,8 @@ _Quoted Printable Encoding_, _qp__ To load directly: (require (lib "qp.ss" "net")) Module files: _qp.ss_ - provides the procedures documented below - _qp-unit.ss_ - provides unit net:qp@ - _qp-sig.ss_ - provides signature net:qp^ + _qp-unit.ss_ - provides unit qp@ + _qp-sig.ss_ - provides signature qp^ ABSTRACT ------------------------------------------------------------- @@ -1867,8 +1867,8 @@ _FTP client_ To load directly: (require (lib "ftp.ss" "net")) Module files: _ftp.ss_ - provides the procedures documented below - _ftp-unit.ss_ - provides unit net:ftp@ - _ftp-sig.ss_ - provides signature net:ftp^ + _ftp-unit.ss_ - provides unit ftp@ + _ftp-sig.ss_ - provides signature ftp^ ABSTRACT ------------------------------------------------------------- @@ -1933,12 +1933,12 @@ _TCP redirect_ ========================================================================== The "tcp-redirect.ss" library provides an function to generate a unit -with the signature net:tcp^ that redirects certain port numbers to -intra-process listeners that do not actually use TCP. The net:tcp^ +with the signature tcp^ that redirects certain port numbers to +intra-process listeners that do not actually use TCP. The tcp^ signature is imported, for example, by the url@ unit of "url-unit.ss". Module file: _tcp-redirect.ss_ - provides the `tcp-redirect-function - _tcp-sig.ss_ - defines _net:tcp^_, which contains the + _tcp-sig.ss_ - defines _tcp^_, which contains the following: tcp-abandon-port tcp-accept @@ -1950,7 +1950,7 @@ Module file: _tcp-redirect.ss_ - provides the `tcp-redirect-function tcp-listen tcp-listener? _tcp-unit.ss_ - defines _tcp@_ which implements - net:tcp^ using the MzScheme functions of + tcp^ using the MzScheme functions of the same name ssl-tcp-unit.ss - see below @@ -1958,7 +1958,7 @@ PROCEDURES ----------------------------------------------------------- > (tcp-redirect port-number-list) - Returns a unit that implements net:tcp^ (from "tcp-sig.ss"). For + Returns a unit that implements tcp^ (from "tcp-sig.ss"). For port numbers not listed in `port-number-list', the unit's implementations are the MzScheme implementations. @@ -1972,7 +1972,7 @@ _SSL redirect__ ========================================================================== The _ssl-tcp-unit.ss_ library provides `make-ssl-tcp@', which returns -a unit that implements net:tcp^ from "tcp-sig.ss" +a unit that implements tcp^ from "tcp-sig.ss" PROCEDURES ----------------------------------------------------------- @@ -1981,7 +1981,7 @@ PROCEDURES ----------------------------------------------------------- server-suggest-auth-file client-cert-file client-key-file client-root-cert-files) - Returns a unit that implements net:tcp^ using the SSL functions from + Returns a unit that implements tcp^ using the SSL functions from (lib "mzssl.ss" "openssl"). The arguments to `make-ssl-tcp@' control the certificates and keys uses by server and client connections: @@ -2008,8 +2008,8 @@ _cookies_, HTTP _State Management_ To load directly: (require (lib "cookie.ss" "net")) Module files: _cookie.ss_ - provides the procedures documented below - _cookie-unit.ss_ - provides unit net:cookie@ - _cookie-sig.ss_ - provides signature net:cookie^ + _cookie-unit.ss_ - provides unit cookie@ + _cookie-sig.ss_ - provides signature cookie^ ABSTRACT ------------------------------------------------------------- @@ -2147,8 +2147,8 @@ _URL encoding_, _URL decoding_, _application/x-www-form-urlencoded_ To load directly: (require (lib "uri-codec.ss" "net")) Module files: _uri-codec.ss_ - provides the procedures documented below - _uri-codec-unit.ss_ - provides unit net:uri-codec@ - _uri-codec-sig.ss_ - provides signature net:uri-codec^ + _uri-codec-unit.ss_ - provides unit uri-codec@ + _uri-codec-sig.ss_ - provides signature uri-codec^ ABSTRACT ------------------------------------------------------------- diff --git a/collects/planet/private/linkage.ss b/collects/planet/private/linkage.ss index e3fbdce540..97ecb23b7e 100644 --- a/collects/planet/private/linkage.ss +++ b/collects/planet/private/linkage.ss @@ -3,8 +3,7 @@ (require "planet-shared.ss" "../config.ss" (lib "file.ss") - (lib "match.ss") - (prefix srfi1: (lib "1.ss" "srfi"))) + (lib "match.ss")) (provide get/linkage get-linkage @@ -173,9 +172,4 @@ ; desuffix : path -> path ; removes the suffix from the given file (define (desuffix file) - (let ((the-extension (filename-extension file)) - (the-bytes (path->bytes file))) - (if the-extension - (bytes->path (list->bytes (reverse (srfi1:drop (reverse (bytes->list the-bytes)) - (add1 (bytes-length the-extension)))))) - file)))) + (path-replace-suffix file #""))) diff --git a/collects/setup/doc.txt b/collects/setup/doc.txt index 8a080cf9e0..3d8916883f 100644 --- a/collects/setup/doc.txt +++ b/collects/setup/doc.txt @@ -262,12 +262,12 @@ namespace. Link the options and setup units so that your option-setting code is initialized between them, e.g.: - (compound-unit/sig + (compound-unit ... (link ... - [OPTIONS : setup-option^ (setup:option@)] - [MY-CODE : () (my-init-options@ OPTIONS)] - [SETUP : () (setup@ OPTIONS ...)]) + [(OPTIONS : setup-option^) setup:option@] + [() my-init-options@ OPTIONS] + [() setup@ OPTIONS ...]) ...) @@ -499,16 +499,17 @@ The raw format is The procedure is extracted from the archive using MzScheme's `read' and `eval' procedures (in a fresh namespace). - * An unsigned unit that drives the unpacking process. The unit - accepts two imports: a path string for the parent of the main - "collects" directory and an `unmztar' procedure. The remainder of - the unpacking process consists of invoking this unit. It is - expected that the unit will call `unmztar' procedure to unpack - directories and files that are defined in the input archive after - this unit. The result of invoking the unit must be a list of - collection paths (where each collection path is a list of strings); - once the archive is unpacked, Setup PLT will compile and setup the - specified collections. + * An old-style, unsigned unit using `(lib "unit200.ss")' that drives + the unpacking process. The unit accepts two imports: a path string + for the parent of the main "collects" directory and an `unmztar' + procedure. The remainder of the unpacking process consists of + invoking this unit. It is expected that the unit will call + `unmztar' procedure to unpack directories and files that are + defined in the input archive after this unit. The result of + invoking the unit must be a list of collection paths (where each + collection path is a list of strings); once the archive is + unpacked, Setup PLT will compile and setup the specified + collections. The `unmztar' procedure takes one argument: a filter procedure. The filter procedure is called for each directory and @@ -618,7 +619,7 @@ general functions to help make .plt archives: [#:file-filter filter-proc] [#:encode? encode?] [#:file-mode file-mode-sym] - [#:unpack-unit unit-expr-or-#f] + [#:unpack-unit unit200-expr-or-#f] [#:collections collection-list] [#:plt-relative? plt-relative?] [#:at-plt-home? at-plt-home?] @@ -648,8 +649,8 @@ general functions to help make .plt archives: is 'file. The `unpack-unit' argument is usually #f. Otherwise, it must be an - S-expression for a unsigned unit that performs the work of - unpacking; see the above section on .plt internals for more + S-expression for a `(lib "unit200.ss")'-style unit that performs the + work of unpacking; see the above section on .plt internals for more information about the unit. If `unpack-unit' is #f, an appropriate unpacking unit is generated. @@ -745,10 +746,8 @@ general functions to help make .plt archives: export of _plt-single-installer.ss_; see above for documentation. - The _plt-installer-unit.ss_ library in the setup collection returns a unit/sig - that imports mred^ and exports setup:plt-installer^. The signature - setup:plt-installer^ has two names: run-installer and on-installer-run, as - above. - The _plt-installer-sig.ss_ library defines the setup:plt-installer^ signature, which has two names: run-installer and on-installer-run. + + The _plt-installer-unit.ss_ library in the setup collection returns a + unit that imports mred^ and exports setup:plt-installer^. diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index fae0aa94a5..32b3f6c7b5 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -14,7 +14,7 @@ real? number? boolean? procedure? symbol? string? bytes? - vector? + vector? box? eof-object?)) (let ([s (with-handlers ([exn? exn-message]) (proc 'bad))] @@ -101,6 +101,8 @@ (un #f 'symbol? #f) (un #t 'vector? (vector 1 2 3)) (un #f 'vector? #f) + (un #t 'box? (box 10)) + (un #f 'box? #f) (un #t 'string? "apple") (un #f 'string? #"apple") (un #f 'bytes? "apple") diff --git a/collects/tests/mzscheme/prompt-tests.ss b/collects/tests/mzscheme/prompt-tests.ss new file mode 100644 index 0000000000..5e00bd8ebe --- /dev/null +++ b/collects/tests/mzscheme/prompt-tests.ss @@ -0,0 +1,1652 @@ + +(test-breaks-ok) + +;;---------------------------------------- +;; Prompt escapes + +;; Simple return +(test 10 call-with-continuation-prompt + (lambda () 10)) +(test-values '(10 11) (lambda () + (call-with-continuation-prompt + (lambda () (values 10 11))))) +(test-values '() (lambda () + (call-with-continuation-prompt + (lambda () (values))))) + +;; Aborts +(test 11 call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + 11)) + (default-continuation-prompt-tag) + values) +(test 11 call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () 11)))) +(test 12 call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + 12)) + (default-continuation-prompt-tag) + values) +(test 12 call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () 12))) + (default-continuation-prompt-tag)) +(test-values '(11 12) + (lambda () + (call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + 11 + 12)) + (default-continuation-prompt-tag) + values))) +(test-values '(11 12) + (lambda () + (call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () (values 11 + 12))))))) +(test 8 call-with-continuation-prompt + (lambda () (+ 17 + (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () 8))))) +(test 81 call-with-continuation-prompt + (lambda () (+ 17 + (call-with-continuation-prompt + (lambda () + (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () 81))) + (make-continuation-prompt-tag))))) +(let ([p (make-continuation-prompt-tag)]) + (test 810 call-with-continuation-prompt + (lambda () (+ 17 + (call-with-continuation-prompt + (lambda () + (abort-current-continuation + p + 810)) + (make-continuation-prompt-tag)))) + p + values)) + +;; Aborts with handler +(test 110 call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + 11)) + (default-continuation-prompt-tag) + (lambda (x) (* x 10))) +(test 23 + call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + 11 + 12)) + (default-continuation-prompt-tag) + (lambda (x y) (+ x y))) +;; Handler in tail position: +(test '(11 12 17) + 'handler-in-tail-position + (with-continuation-mark + 'x 16 + (call-with-continuation-prompt + (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + 11 + 12)) + (default-continuation-prompt-tag) + (lambda (x y) + (with-continuation-mark + 'x 17 + (list* x y + (continuation-mark-set->list + (current-continuation-marks) + 'x))))))) + +(test-breaks-ok) + +;; Abort to a prompt in a d-w post that is deeper than a +;; prompt with the same tag at the continuation-jump site: +(test 0 + values + (let ([p1 (make-continuation-prompt-tag)] + [p2 (make-continuation-prompt-tag)]) + (let/cc k + (call-with-continuation-prompt + (lambda () + (call-with-continuation-prompt + (lambda () + (dynamic-wind + void + (lambda () + (call-with-continuation-prompt + (lambda () + (k 0)) + p2)) + (lambda () + (abort-current-continuation p1 (lambda () 0))))) + p1)) + p2)))) + +;; ---------------------------------------- +;; Continuations + +(with-cc-variants + (test -17 + call-with-continuation-prompt + (lambda () -17))) + +(with-cc-variants + (test 17 + call-with-continuation-prompt + (lambda () + (let/cc k + (k 17))))) + +(test-breaks-ok) + +(with-cc-variants + (test 29 + 'in-other-prompt1 + (let ([retry #f]) + (test 35 + call-with-continuation-prompt + (lambda () + (+ 18 + (let/cc k + (set! retry k) + 17)))) + (+ 1 (call-with-continuation-prompt + (lambda () + (retry 10))))))) + +(with-cc-variants + (test 60 + 'in-other-prompt2 + (let ([retry #f]) + (test 35 + call-with-continuation-prompt + (lambda () + (+ 18 + (let/cc k + (set! retry k) + 17)))) + (+ 1 (call-with-continuation-prompt + (lambda () + (+ (call-with-continuation-prompt + (lambda () + (retry 12))) + (call-with-continuation-prompt + (lambda () + (retry 11)))))))))) + +(with-cc-variants + (test '(#f #t) + 'in-other-thread1 + (let ([retry #f] + [result #f] + [did? #f]) + (call-with-continuation-prompt + (lambda () + (+ 18 + (begin0 + (let/cc k + (set! retry k) + 17) + (set! did? #t))))) + (set! did? #f) + (thread-wait + (thread (lambda () + (set! result (retry 0))))) + (list result did?)))) + +(with-cc-variants + (test 18 + 'in-other-thread2 + (let ([retry #f] + [result #f]) + (call-with-continuation-prompt + (lambda () + (+ 18 + (let/cc k + (set! retry k) + 17)))) + (thread-wait + (thread (lambda () + (set! result + (call-with-continuation-prompt + (lambda () + (retry 0))))))) + result))) + +(with-cc-variants + (test 25 + 'back-in-original-thread + (let ([retry #f] + [result #f]) + (thread-wait + (thread + (lambda () + (+ 18 + (let/cc k + (set! retry k) + 17))))) + (call-with-continuation-prompt + (lambda () + (retry 7)))))) + +(test-breaks-ok) + +;; Catch continuation in composed continuation: +(with-cc-variants + (test 89 + 'catch-composed + (let ([k (call-with-continuation-prompt + (lambda () + ((let/cc k (lambda () k)))))]) + (let ([k2 (call-with-continuation-prompt + (lambda () + (k (lambda () + (car (let/cc k2 (list k2)))))))]) + (call-with-continuation-prompt + (lambda () + (k2 '(89)))))))) + +;; Grab continuation shallow inside meta-prompt with +;; delimiting prompt deep in a different meta-prompt. +(with-cc-variants + (let ([k (call-with-continuation-prompt + (lambda () + ((call/cc + (lambda (k) (lambda () k))))))]) + (test 10 call-with-continuation-prompt + (lambda () + (let loop ([n 300]) + (if (zero? n) + (k (lambda () + (let/cc k2 (k2 10)))) + (cons n (loop (sub1 n))))))))) + +;; Grab continuation deep inside meta-prompt with +;; delimiting prompt shallow in a different meta-prompt. +(with-cc-variants + (let ([k (call-with-continuation-prompt + (lambda () + (let loop ([n 12]) + (if (zero? n) + ((call/cc + (lambda (k) (lambda () k)))) + (cons 1 (loop (sub1 n)))))))]) + (test '(1 1 1 1 1 1 1 1 1 1 1 1 . 10) call-with-continuation-prompt + (lambda () + ((list-tail k 12) + (lambda () + (let/cc k2 (k2 10)))))))) + +(test-breaks-ok) + +;; ---------------------------------------- +;; Overlapping continuations + +;; Nested +(let ([p1 (make-continuation-prompt-tag)] + [p2 (make-continuation-prompt-tag)]) + (let ([k1 #f] + [k2 #f]) + (test '(p1 p2 100) + call-with-continuation-prompt + (lambda () + (cons 'p1 + (call-with-continuation-prompt + (lambda () + (cons 'p2 + ((call/cc + (lambda (-k1) + (set! k1 -k1) + (call/cc (lambda (-k2) + (set! k2 -k2) + (lambda () '(100))) + p2)) + p1)))) + p2))) + p1) + (err/rt-test (k1) exn:fail:contract:continuation?) + (err/rt-test (k2) exn:fail:contract:continuation?) + (err/rt-test (call-with-continuation-prompt + (lambda () (k1)) + p2) + exn:fail:contract:continuation?) + (err/rt-test (call-with-continuation-prompt + (lambda () (k2)) + p1) + exn:fail:contract:continuation?) + (test '(p1 p2 101) call-with-continuation-prompt + (lambda () + (k1 (lambda () '(101)))) + p1) + (test '(p2 102) call-with-continuation-prompt + (lambda () + (k2 (lambda () '(102)))) + p2) + (test '(p1 p2 102-1) call-with-continuation-prompt + (lambda () + (k1 (lambda () (k2 (lambda () '(102-1)))))) + p1))) + +;; Use default tag to catch a meta-continuation of p1. +;; Due to different implementations of the default tag, +;; this test is interesting in the main thread and +;; a sub thread: +(let () + (define (go) + (let ([p1 (make-continuation-prompt-tag)]) + (let ([k (call-with-continuation-prompt + (lambda () + ((call/cc (lambda (k) (lambda () k)) + p1))) + p1)]) + (let ([k2 (list + (call-with-continuation-prompt + (lambda () + (k (lambda () + (let/cc k k)))) + p1))]) + (if (procedure? (car k2)) + ((car k2) 10) + (test '(10) values k2)))))) + (go) + (let ([finished #f]) + (thread-wait + (thread (lambda () + (go) + (set! finished 'finished)))) + (test 'finished values finished))) + +;; Use default tag to catch a meta-continuation of p1, +;; then catch continuation again (i.e., loop). +(let ([finished #f]) + (define (go) + (let ([p1 (make-continuation-prompt-tag)] + [counter 10]) + (let ([k (call-with-continuation-prompt + (lambda () + ((call/cc (lambda (k) (lambda () k)) + p1))) + p1)]) + (let ([k2 (list + (call-with-continuation-prompt + (lambda () + (k (lambda () + ((let/cc k (lambda () k)))))) + p1))]) + (if (procedure? (car k2)) + ((car k2) (lambda () + (if (zero? counter) + 10 + (begin + (set! counter (sub1 counter)) + ((let/cc k (lambda () k))))))) + (test '(10) values k2)) + (set! finished 'finished))))) + (go) + (let ([finished #f]) + (thread-wait + (thread (lambda () + (go) + (set! finished 'finished)))) + (test 'finished values finished))) + +;; ---------------------------------------- +;; Composable continuations + +(err/rt-test (call-with-continuation-barrier + ;; When the test is not run in a REPL but is run in the + ;; main thread, then it should fail without the barrier, + ;; too. But we don't have enough control over the test + ;; environment to assume that. + (lambda () + (call-with-composable-continuation + (lambda (x) x)))) + exn:fail:contract:continuation?) + +(err/rt-test (call-with-composable-continuation + (lambda (x) x) + (make-continuation-prompt-tag 'px)) + exn:fail:contract?) + +(let ([k (call-with-continuation-prompt + (lambda () + (call-with-composable-continuation + (lambda (k) k))))]) + (test 12 k 12) + (test 13 k (k (k (k 13)))) + (test-values '(12 13) (lambda () (k 12 13)))) + +(let ([k (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) (lambda () k))))))]) + (test 12 k (lambda () 12)) + (test-values '(12 13) (lambda () (k (lambda () (values 12 13))))) + ;; Composition shouldn't introduce a prompt: + (test 10 call-with-continuation-prompt + (lambda () + (let ([k2 (k (lambda () + (let/cc k2 k2)))]) + (if (procedure? k2) + (k2 10) + k2)))) + ;; Escape from composed continuation: + (let ([p (make-continuation-prompt-tag)]) + (test 8 call-with-continuation-prompt + (lambda () + (+ 99 (k (lambda () (abort-current-continuation p 8))))) + p + values)) + (test 8 call-with-continuation-prompt + (lambda () + (+ 99 (k (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + 8))))) + (default-continuation-prompt-tag) + values)) + +;; Etc. +(let ([k1 (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))] + [k2 (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))]) + (test 1000 + call-with-continuation-prompt + (lambda () + (k1 (lambda () (k2 (lambda () 1000)))))) + (test -1000 k1 (lambda () (k2 (lambda () -1000)))) + + (let ([k3 (call-with-continuation-prompt + (lambda () + (k1 (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))))]) + (test 1001 + call-with-continuation-prompt + (lambda () + (k3 (lambda () 1001)))) + (test -1001 k3 (lambda () -1001)) + (test 1002 + call-with-continuation-prompt + (lambda () + (k1 (lambda () (k3 (lambda () 1002)))))) + (test -1002 k1 (lambda () (k3 (lambda () -1002))))) + + (let ([k4 (call-with-continuation-prompt + (lambda () + (k1 + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))))]) + (test -1003 k4 (lambda () -1003))) + + (let ([k5 (call-with-continuation-prompt + (lambda () + ((k1 + (lambda () + (call-with-composable-continuation + (lambda (k) + (lambda () k))))))))]) + (test -1004 k5 (lambda () -1004)) + + (let ([k6 (call-with-continuation-prompt + (lambda () + ((k5 + (lambda () + (call-with-composable-continuation + (lambda (k) + (lambda () k))))))))]) + (test -1005 k6 (lambda () -1005)))) + + (let ([k7 (call-with-continuation-prompt + (lambda () + ((k1 + (lambda () + ((k1 + (lambda () + (call-with-composable-continuation + (lambda (k) + (lambda () (lambda () k))))))))))))]) + (test -1006 k7 (lambda () (lambda () -1006))) + (test '(-1007) call-with-continuation-prompt + (lambda () + (list (k7 (lambda () (lambda () -1007))))))) + + ) + +;; Check that escape drops the meta-continuation: +(test 0 + 'esc + (let ([p1 (make-continuation-prompt-tag)]) + (let/cc esc + (let ([k + (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k)) + p1))) + p1)]) + (/ (k (lambda () (esc 0)))))))) + +;; ---------------------------------------- +;; Dynamic wind + +(test 89 + 'dw + (let ([k (dynamic-wind + void + (lambda () (let ([k+e (let/cc k (cons k void))]) + ((cdr k+e) 89) + (car k+e))) + void)]) + (let/cc esc + (k (cons void esc))))) + +(let ([l null]) + (let ([k2 + (dynamic-wind + (lambda () (set! l (cons 'pre0 l))) + (lambda () + (let ([k (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (set! l (cons 'pre l))) + (lambda () (let ([k (let/cc k k)]) + k)) + (lambda () (set! l (cons 'post l))))))]) + (test '(post pre pre0) values l) + ;; Jump from one to the other: + (let ([k2 + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (set! l (cons 'pre2 l))) + (lambda () + (dynamic-wind + (lambda () (set! l (cons 'pre3 l))) + (lambda () + (let/cc k2 (k k2))) + (lambda () (set! l (cons 'post3 l))))) + (lambda () (set! l (cons 'post2 l))))))]) + (test '(post pre post2 post3 pre3 pre2 post pre pre0) values l) + k2))) + (lambda () (set! l (cons 'post0 l))))]) + (test '(post0 post pre post2 post3 pre3 pre2 post pre pre0) values l) + ;; Restore in context with fewer DWs: + (test 8 call-with-continuation-prompt (lambda () (k2 8))) + (test '(post2 post3 pre3 pre2 post0 post pre post2 post3 pre3 pre2 post pre pre0) values l) + ;; Restore in context with more DWs: + (set! l null) + (dynamic-wind + (lambda () (set! l (cons 'pre4 l))) + (lambda () + (dynamic-wind + (lambda () (set! l (cons 'pre5 l))) + (lambda () + (call-with-continuation-prompt k2)) + (lambda () (set! l (cons 'post5 l))))) + (lambda () (set! l (cons 'post4 l)))) + (test '(post4 post5 post2 post3 pre3 pre2 pre5 pre4) values l))) + +;; Like the meta-continuation test above, but add a dynamic wind +;; to be restored in the p1 continuation: +(let ([p1 (make-continuation-prompt-tag)] + [did #f]) + (let ([k (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () + (set! did 'in)) + (lambda () + ((call/cc (lambda (k) (lambda () k)) + p1))) + (lambda () + (set! did 'out)))) + p1)]) + (set! did #f) + (let ([k2 (list + (call-with-continuation-prompt + (lambda () + (k (lambda () + (test 'in values did) + ((let/cc k (lambda () k)))))) + p1))]) + (test 'out values did) + (if (procedure? (car k2)) + ((car k2) (lambda () + (test 'in values did) + 10)) + (test '(10) values k2))))) + +;; Composable continuations +(let ([l null]) + (let ([k2 + (dynamic-wind + (lambda () (set! l (cons 'pre0 l))) + (lambda () + (let ([k (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (set! l (cons 'pre l))) + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))) + (lambda () (set! l (cons 'post l))))))]) + (test '(post pre pre0) values l) + (test 12 k (lambda () 12)) + (test '(post pre post pre pre0) values l) + k)) + (lambda () (set! l (cons 'post0 l))))]) + (test '(post0 post pre post pre pre0) values l) + (test 73 k2 (lambda () 73)) + (test '(post pre post0 post pre post pre pre0) values l) + (set! l null) + ;; Add d-w inside k2: + (let ([k3 (call-with-continuation-prompt + (lambda () + (k2 (lambda () + (dynamic-wind + (lambda () (set! l (cons 'pre2 l))) + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))) + (lambda () (set! l (cons 'post2 l))))))))]) + (test '(post post2 pre2 pre) values l) + (test 99 k3 (lambda () 99)) + (test '(post post2 pre2 pre post post2 pre2 pre) values l)) + (set! l null) + ;; Add d-w outside k2: + (let ([k4 (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (set! l (cons 'pre2 l))) + (lambda () + (k2 (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))) + (lambda () (set! l (cons 'post2 l))))))]) + (test '(post2 post pre pre2) values l) + (test 99 k4 (lambda () 99)) + (test '(post2 post pre pre2 post2 post pre pre2) values l)))) + +;; Jump back into post: +(let ([l null] + [p1 (make-continuation-prompt-tag)] + [p2 (make-continuation-prompt-tag)] + [k2 #f]) + (define (out v) (set! l (cons v l))) + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (out 'pre)) + (lambda () + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (out 'pre2)) + (lambda () (void)) + (lambda () + (call/cc (lambda (k) + (set! k2 k)) + p2) + (out 'post2)))) + p2)) + (lambda () (out 'post1)))) + p1) + (call-with-continuation-prompt + (lambda () + (k2 10)) + p2) + (test '(post2 post1 post2 pre2 pre) values l)) + +;; Jump into post, then back out +(let ([l null] + [p1 (make-continuation-prompt-tag)] + [p2 (make-continuation-prompt-tag)] + [k2 #f] + [count 0]) + (define (out v) (set! l (cons v l))) + (let/cc esc + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (out 'pre1)) + (lambda () + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (out 'pre2)) + (lambda () (void)) + (lambda () + (call/cc (lambda (k) + (set! k2 k)) + p2) + (out 'post2) + (esc)))) + p2)) + (lambda () (out 'post1)))) + p1)) + (printf "here ~a\n" count) + (set! count (add1 count)) + (unless (= count 3) + (call-with-continuation-prompt + (lambda () + (k2 10)) + p2)) + (test '(post2 post2 post1 post2 pre2 pre1) values l)) + +(printf "into post from escape\n") + +;; Jump into post from an escape, rather than +;; from a result continuation +(let ([l null] + [p1 (make-continuation-prompt-tag)] + [p2 (make-continuation-prompt-tag)] + [k2 #f] + [count 0]) + (define (out v) (set! l (cons v l))) + (let/cc esc + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (out 'pre1)) + (lambda () + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (out 'pre2)) + (lambda () (esc)) + (lambda () + (call/cc (lambda (k) + (set! k2 k)) + p2) + (out 'post2)))) + p2)) + (lambda () (out 'post1)))) + p1)) + (set! count (add1 count)) + (unless (= count 3) + (call-with-continuation-prompt + (lambda () + (k2 10)) + p2)) + (test '(post2 post2 post1 post2 pre2 pre1) values l)) + +;; ---------------------------------------- +;; Continuation marks + +(let ([go + (lambda (access-tag catch-tag blocked?) + (let ([k (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'x + 17 + ((call/cc (lambda (k) (lambda () k)) + catch-tag)))) + catch-tag)]) + (with-continuation-mark + 'x + 18 + (with-continuation-mark + 'y + 8 + (begin + (printf "here\n") + (test 18 continuation-mark-set-first #f 'x #f catch-tag) + (test '(18) continuation-mark-set->list (current-continuation-marks catch-tag) 'x catch-tag) + (test 17 + call-with-continuation-prompt + (lambda () + (k (lambda () (continuation-mark-set-first #f 'x #f catch-tag)))) + catch-tag) + (test 8 + call-with-continuation-prompt + (lambda () + (k (lambda () (continuation-mark-set-first #f 'y #f catch-tag)))) + catch-tag) + (test (if blocked? + '(17) + '(17 18)) + call-with-continuation-prompt + (lambda () + (k (lambda () (continuation-mark-set->list (current-continuation-marks access-tag) + 'x access-tag)))) + catch-tag) + (test '(17) + continuation-mark-set->list (continuation-marks k catch-tag) 'x catch-tag) + (test (if blocked? + '() + '(8)) + call-with-continuation-prompt + (lambda () + (k (lambda () (continuation-mark-set->list (current-continuation-marks access-tag) + 'y access-tag)))) + catch-tag) + + 'done)))))]) + (go (default-continuation-prompt-tag) (default-continuation-prompt-tag) #t) + (let ([p2 (make-continuation-prompt-tag 'p2)]) + (call-with-continuation-prompt + (lambda () + (go p2 p2 #t) + (go p2 (default-continuation-prompt-tag) #f) + (go (default-continuation-prompt-tag) p2 #f)) + p2))) + +(define (non-tail v) (values v)) + +(let () + (define (go access-tag blocked?) + (let ([k (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'x + 71 + ((call-with-composable-continuation + (lambda (k) + (lambda () k)))))))]) + (test #f continuation-mark-set-first #f 'x) + (test 71 k (lambda () (continuation-mark-set-first #f 'x))) + (test '(71) continuation-mark-set->list (continuation-marks k) 'x) + (test 71 'wcm (with-continuation-mark + 'x 81 + (k (lambda () (continuation-mark-set-first #f 'x))))) + (test '(71 81) 'wcm (with-continuation-mark + 'x 81 + (non-tail + (k (lambda () + (continuation-mark-set->list (current-continuation-marks) 'x)))))) + (test '(71) 'wcm (with-continuation-mark + 'x 81 + (k (lambda () + (continuation-mark-set->list (current-continuation-marks) 'x))))) + (test '(91 71 81) 'wcm (with-continuation-mark + 'x 81 + (non-tail + (k (lambda () + (non-tail + (with-continuation-mark + 'x 91 + (continuation-mark-set->list (current-continuation-marks) 'x)))))))) + (test '(91 81) 'wcm (with-continuation-mark + 'x 81 + (non-tail + (k (lambda () + (with-continuation-mark + 'x 91 + (continuation-mark-set->list (current-continuation-marks) 'x))))))) + (test '(91) 'wcm (with-continuation-mark + 'x 81 + (k (lambda () + (with-continuation-mark + 'x 91 + (continuation-mark-set->list (current-continuation-marks) 'x)))))) + (let ([k2 (with-continuation-mark + 'x 101 + (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'x 111 + (non-tail + (k (lambda () + ((call-with-composable-continuation + (lambda (k2) + (test (if blocked? + '(71 111) + '(71 111 101)) + continuation-mark-set->list (current-continuation-marks access-tag) + 'x access-tag) + (lambda () k2)))))))))))]) + (test '(71 111) continuation-mark-set->list (continuation-marks k2) 'x) + (test '(71 111) k2 (lambda () + (continuation-mark-set->list (current-continuation-marks) 'x))) + (test 71 k2 (lambda () + (continuation-mark-set-first #f 'x))) + (test '(71 111 121) 'wcm (with-continuation-mark + 'x 121 + (non-tail + (k2 (lambda () + (continuation-mark-set->list (current-continuation-marks) 'x)))))) + ) + + (let ([k2 (with-continuation-mark + 'x 101 + (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'x 111 + (k (lambda () + ((call-with-composable-continuation + (lambda (k2) + (test (if blocked? + '(71) + '(71 101)) + continuation-mark-set->list (current-continuation-marks access-tag) + 'x access-tag) + (lambda () k2))))))))))]) + (test '(71) continuation-mark-set->list (continuation-marks k2) 'x) + (test '(71) k2 (lambda () + (continuation-mark-set->list (current-continuation-marks) 'x))) + (test 71 k2 (lambda () + (continuation-mark-set-first #f 'x))) + (test '(71 121) 'wcm (with-continuation-mark + 'x 121 + (non-tail + (k2 (lambda () + (continuation-mark-set->list (current-continuation-marks) 'x))))))))) + (go (default-continuation-prompt-tag) #t) + (let ([p2 (make-continuation-prompt-tag 'p2)]) + (call-with-continuation-prompt + (lambda () + (go p2 #f)) + p2))) + +;; Check interaction of dynamic winds, continuation composition, and continuation marks +(let ([pre-saw-xs null] + [post-saw-xs null] + [pre-saw-ys null] + [post-saw-ys null]) + (let ([k (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'x + 77 + (dynamic-wind + (lambda () + (set! pre-saw-xs (continuation-mark-set->list (current-continuation-marks) 'x)) + (set! pre-saw-ys (continuation-mark-set->list (current-continuation-marks) 'y))) + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))) + (lambda () + (set! post-saw-xs (continuation-mark-set->list (current-continuation-marks) 'x)) + (set! post-saw-ys (continuation-mark-set->list (current-continuation-marks) 'y)))))))]) + (test '(77) values pre-saw-xs) + (test '() values pre-saw-ys) + (test '(77) values post-saw-xs) + (test '() values post-saw-ys) + (let ([jump-in + (lambda (wrap r-val y-val) + (test r-val 'wcm + (wrap + (lambda (esc) + (with-continuation-mark + 'y y-val + (k (lambda () (esc))))))) + (test '(77) values pre-saw-xs) + (test (list y-val) values pre-saw-ys) + (test '(77) values post-saw-xs) + (test (list y-val) values post-saw-ys) + (let ([k3 (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))]) + (test r-val 'wcm + (wrap + (lambda (esc) + (k3 + (lambda () + (with-continuation-mark + 'y y-val + (k (lambda () (k3 (lambda () (esc)))))))))))))]) + (jump-in (lambda (f) (f (lambda () 10))) 10 88) + (jump-in (lambda (f) (let/cc esc (f (lambda () (esc 20))))) 20 99) + (printf "here\n") + (jump-in (lambda (f) + (let ([p1 (make-continuation-prompt-tag)]) + (call-with-continuation-prompt + (lambda () + (f (lambda () (abort-current-continuation p1 (lambda () 30))))) + p1))) + 30 111) + (void)))) + +;; Tail meta-calls should overwrite continuation marks +(let ([k (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))]) + (with-continuation-mark + 'n #f + (let loop ([n 10]) + (unless (zero? n) + (with-continuation-mark + 'n n + (k (lambda () + (test (list n) continuation-mark-set->list (current-continuation-marks) 'n) + (loop (sub1 n))))))))) + +;; Tail meta-calls should propagate cont marks +(let ([k (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))]) + (with-continuation-mark + 'n 10 + (let loop ([n 10]) + (test n continuation-mark-set-first #f 'n) + (test (list n) continuation-mark-set->list (current-continuation-marks) 'n) + (unless (zero? n) + (k (lambda () + (with-continuation-mark + 'n (sub1 n) + (loop (sub1 n))))))))) + +;; Captured mark should replace installed mark +(let ([k (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'n #t + ((call-with-composable-continuation + (lambda (k) + (lambda () k)))))))]) + (with-continuation-mark + 'n #f + (let loop ([n 10]) + (unless (zero? n) + (with-continuation-mark + 'n n + (k (lambda () + (test (list #t) continuation-mark-set->list (current-continuation-marks) 'n) + (test #t continuation-mark-set-first #f 'n) + (loop (sub1 n))))))))) + +;; ---------------------------------------- +;; Olivier Danvy's traversal + +;; Shift & reset via composable and abort +(let () + (define traverse + (lambda (xs) + (letrec ((visit + (lambda (xs) + (if (null? xs) + '() + (visit (call-with-composable-continuation + (lambda (k) + (abort-current-continuation + (default-continuation-prompt-tag) + (let ([v (cons (car xs) + (call-with-continuation-prompt + (lambda () + (k (cdr xs)))))]) + (lambda () v)))))))))) + (call-with-continuation-prompt + (lambda () + (visit xs)))))) + (test '(1 2 3 4 5) traverse '(1 2 3 4 5))) + +;; Shift & reset using composable and call/cc +(let () + (define call-in-application-context + (call-with-continuation-prompt + (lambda () + ((call-with-current-continuation + (lambda (k) (lambda () k))))))) + (define traverse + (lambda (xs) + (letrec ((visit + (lambda (xs) + (if (null? xs) + '() + (visit (call-with-composable-continuation + (lambda (k) + (call-in-application-context + (lambda () + (cons (car xs) + (call-with-continuation-prompt + (lambda () + (k (cdr xs)))))))))))))) + (call-with-continuation-prompt + (lambda () + (visit xs)))))) + (test '(1 2 3 4 5) traverse '(1 2 3 4 5))) + +;; control and prompt using composable and abort +(let () + (define traverse + (lambda (xs) + (letrec ((visit + (lambda (xs) + (if (null? xs) + (list-tail '() 0) + (visit (call-with-composable-continuation + (lambda (k) + (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () + (cons (car xs) + (k (cdr xs)))))))))))) + (call-with-continuation-prompt + (lambda () + (visit xs)))))) + (test '(5 4 3 2 1) traverse '(1 2 3 4 5))) + +;; control and prompt using composable and call/cc +(let () + (define call-in-application-context + (call-with-continuation-prompt + (lambda () + ((call-with-current-continuation + (lambda (k) (lambda () k))))))) + (define traverse + (lambda (xs) + (letrec ((visit + (lambda (xs) + (if (null? xs) + (list-tail '() 0) + (visit (call-with-composable-continuation + (lambda (k) + (call-in-application-context + (lambda () + (cons (car xs) + (k (cdr xs)))))))))))) + (call-with-continuation-prompt + (lambda () + (visit xs)))))) + (test '(5 4 3 2 1) traverse '(1 2 3 4 5))) + +;; ---------------------------------------- +;; Check unwinding of runstack overflows on prompt escape + +(let ([try + (lambda (thread m-top n-top do-mid-stream do-abort) + (let ([result #f]) + (thread-wait + (thread + (lambda () + (set! result + (let pre-loop ([m m-top]) + (if (zero? m) + (list + (do-mid-stream + (lambda () + (call-with-continuation-prompt + (lambda () + (let loop ([n n-top]) + (if (zero? n) + (do-abort + (lambda () + (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () 5000)))) + (+ (loop (sub1 n)))))))))) + (list (car (pre-loop (sub1 m)))))))))) + (test '(5000) values result)))]) + (try thread 5000 10000 (lambda (mid) (mid)) (lambda (abort) (abort))) + (try thread 5000 10000 (lambda (mid) (mid)) + (lambda (abort) ((call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) (lambda () k)))))) + (lambda () 5000)))) + (try thread 5000 10000 (lambda (mid) (mid)) + (lambda (abort) ((call-with-continuation-prompt + (lambda () + ((call/cc + (lambda (k) (lambda () k)))))) + (lambda () 5000)))) + (try thread 5000 10000 (lambda (mid) (mid)) + (lambda (abort) (((call/cc + (lambda (k) (lambda () k)))) + (lambda () (lambda (x) 5000))))) + (try thread 5000 10000 + (lambda (mid) (call-with-continuation-barrier mid)) + (lambda (abort) (((call/cc + (lambda (k) (lambda () k)))) + (lambda () (lambda (x) 5000))))) + (let ([p (make-continuation-prompt-tag 'p)]) + (try (lambda (f) + (thread + (lambda () + (call-with-continuation-prompt f p)))) + 5000 10000 + (lambda (mid) (mid)) + (lambda (abort) + ((call/cc + (lambda (k) + (thread-wait (thread + (lambda () + (call-with-continuation-prompt + (lambda () + (k abort)) + p)))) + (lambda () (abort-current-continuation p void))) + p))))) + ) + +(test-breaks-ok) + +;; ---------------------------------------- +;; Some repeats, but ensure a continuation prompt +;; and check d-w interaction. + +(let ([output null]) + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (set! output (cons 'in output))) + (lambda () + (let ([finished #f]) + (define (go) + (let ([p1 (make-continuation-prompt-tag)] + [counter 10]) + (let ([k (call-with-continuation-prompt + (lambda () + ((call/cc (lambda (k) (lambda () k)) + p1))) + p1)]) + (let ([k2 (list + (call-with-continuation-prompt + (lambda () + (k (lambda () + ((let/cc k (lambda () k)))))) + p1))]) + (current-milliseconds) + (if (procedure? (car k2)) + ((car k2) (lambda () + (if (zero? counter) + 10 + (begin + (set! counter (sub1 counter)) + ((let/cc k (lambda () k))))))) + (values '(10) values k2)) + (set! finished 'finished))))) + (go))) + (lambda () (set! output (cons 'out output))))) + (default-continuation-prompt-tag) + void) + (test '(out in) values output)) + +(let ([output null]) + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (set! output (cons 'in output))) + (lambda () + (let ([p1 (make-continuation-prompt-tag)]) + (let/cc esc + (let ([k + (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k)) + p1))) + p1)]) + (/ (k (lambda () (esc 0)))))))) + (lambda () (set! output (cons 'out output))))) + (default-continuation-prompt-tag) + void) + (test '(out in) values output)) + +;;---------------------------------------- +;; tests invoking delimited captures in dynamic-wind pre- and post-thunks + +;; Arrange for a post-thunk to remove a target +;; for an escape: +(err/rt-test + (let ([p1 (make-continuation-prompt-tag 'p1)] + [exit-k #f]) + (let ([x (let/ec esc + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (void)) + (lambda () (esc 'done)) + (lambda () + ((call/cc + (lambda (k) + (set! exit-k k) + (lambda () 10)) + p1)) + (printf "post\n")))) + p1))]) + (call-with-continuation-barrier + (lambda () + (call-with-continuation-prompt + (lambda () + (exit-k (lambda () 'hi))) + p1))))) + exn:fail:contract:continuation?) + +;; Same thing, but escape via prompt: +(err/rt-test + (let ([p1 (make-continuation-prompt-tag 'p1)] + [p2 (make-continuation-prompt-tag 'p2)] + [output null] + [exit-k #f]) + (let ([x (call-with-continuation-prompt + (lambda () + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (void)) + (lambda () (abort-current-continuation p2 1 2 3)) + (lambda () + ((call/cc + (lambda (k) + (set! exit-k k) + (lambda () 10)) + p1)) + (set! output (cons 'post output))))) + p1)) + p2 + void)]) + (call-with-continuation-barrier + (lambda () + (call-with-continuation-prompt + (lambda () + (exit-k (lambda () 'hi))) + p1))))) + exn:fail:contract?) + +;; Arrange for a barrier to interfere with a continuation +;; jump after dynamic-winds are already being processed: +(let ([p1 (make-continuation-prompt-tag 'p1)] + [output null] + [exit-k #f]) + (let ([go + (lambda (launch) + (let ([k (let/cc esc + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (void)) + (lambda () + (with-handlers ([void (lambda (exn) + (test #f "should not be used!" #t))]) + (launch esc))) + (lambda () + ((call/cc + (lambda (k) + (set! exit-k k) + (lambda () 10)) + p1)) + (set! output (cons 'post output))))) + p1))]) + (call-with-continuation-barrier + (lambda () + (call-with-continuation-prompt + (lambda () + (exit-k (lambda () 'hi))) + p1)))))]) + (err/rt-test + (go (lambda (esc) (esc 'middle))) + exn:fail:contract:continuation?) + (test '(post post) values output) + (let ([meta (call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) (lambda () k))))))]) + (err/rt-test + (go (lambda (esc) + (meta + (lambda () (esc 'ok))))) + exn:fail:contract:continuation?)) + (test '(post post post post) values output))) + +;; Similar, but more checking of dropped d-ws: +(let ([p1 (make-continuation-prompt-tag 'p1)] + [output null] + [exit-k #f] + [done? #f]) + ;; Capture a continuation w.r.t. the default prompt tag: + (call/cc + (lambda (esc) + (dynamic-wind + (lambda () (void)) + (lambda () + ;; Set a prompt for tag p1: + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (void)) + ;; inside d-w, jump out: + (lambda () (esc 'done)) + (lambda () + ;; As we jump out, capture a continuation + ;; w.r.t. p1: + ((call/cc + (lambda (k) + (set! exit-k k) + (lambda () 10)) + p1)) + (set! output (cons 'inner output))))) + p1)) + (lambda () + ;; This post thunk is not in the + ;; delimited continuation captured + ;; via tag p1: + (set! output (cons 'outer output)))))) + (unless done? + (set! done? #t) + ;; Now invoke the delimited continuation, which must + ;; somehow continue the jump to `esc': + (call-with-continuation-prompt + (lambda () + (exit-k (lambda () 10))) + p1)) + (test '(inner outer inner) values output)) + +;; Again, more checking of output +(let ([p1 (make-continuation-prompt-tag 'p1)] + [p2 (make-continuation-prompt-tag 'p2)] + [output null] + [exit-k #f]) + ;; Set up a prompt tp jump to: + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (void)) + (lambda () + ;; Set a prompt for tag p1: + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (void)) + ;; inside d-w, jump out: + (lambda () (abort-current-continuation + p2 + "done")) + (lambda () + ;; As we jump out, capture a continuation + ;; w.r.t. p1: + ((call/cc + (lambda (k) + (set! exit-k k) + (lambda () 10)) + p1)) + (set! output (cons 'inner output))))) + p1)) + (lambda () + ;; This post thunk is not in the + ;; delimited continuation captured + ;; via tag p1: + (set! output (cons 'outer output))))) + p2 + (lambda (v) + (set! output (cons 'orig output)))) + ;; Now call, redirecting the escape to here: + (call-with-continuation-prompt + (lambda () + (call-with-continuation-prompt + (lambda () + (exit-k (lambda () 10))) + p1)) + p2 + (lambda (v) + (set! output (cons 'new output)))) + (test '(new inner orig outer inner) values output)) + +;; abort past a tag +(test 10 + values + (let ([p1 (make-continuation-prompt-tag)] + [p2 (make-continuation-prompt-tag)]) + (call-with-continuation-prompt + (lambda () + (call/cc + (lambda (k) + (call-with-continuation-prompt + (lambda () + (k 10)) + p2)) + p1)) + p1))) + +;; Check that a prompt is not somehow tied to its original +;; barrier, so that jumps are not allowed when they should +;; be: +(test 0 + values + (let ([p1 (make-continuation-prompt-tag 'p1)] + [p2 (make-continuation-prompt-tag 'p2)]) + (let ([k (call-with-continuation-prompt + (lambda () + (call-with-continuation-prompt + (lambda () + ((call-with-current-continuation + (lambda (k) (lambda () k)) + p2))) + p1)) + p2)]) + (call-with-continuation-barrier + (lambda () + (call-with-continuation-barrier + (lambda () + (let ([k1 + (call-with-continuation-prompt + (lambda () + (k + (lambda () + ;; prompt for p1 has been restored + (call/cc (lambda (k1) k1) p1)))) + p2)]) + (call-with-continuation-prompt + (lambda () + (k1 0)) + p1))))))))) + +(test 12 + values + (let ([p1 (make-continuation-prompt-tag 'p1)]) + (let ([k (call-with-continuation-barrier + (lambda () + (call-with-continuation-prompt + (lambda () + ((call-with-current-continuation + (lambda (k) (lambda () k)) + p1))) + p1)))]) + (call-with-continuation-barrier + (lambda () + (call-with-continuation-barrier + (lambda () + (call-with-continuation-barrier + (lambda () + (call-with-continuation-prompt + (lambda () + (let/cc w + (call-with-continuation-prompt + (lambda () + (k (lambda () (w 12)))) + p1))))))))))))) + +;; ---------------------------------------- +;; Try long chain of composable continuations + +(let ([long-loop + (lambda (on-overflow) + (let ([v (make-vector 6)]) + (vector-set-performance-stats! v) + (let ([overflows (vector-ref v 5)]) + ;; Although this is a constant-space loop, the implementation + ;; pushes each captured continuation further and further down + ;; the C stack. Eventually, the relevant segment wraps around, + ;; with an overflow. Push a little deeper and then capture + ;; that. + (let loop ([n 0][fuel #f]) + (vector-set-performance-stats! v) + (cond + [(and (not fuel) + ((vector-ref v 5) . > . overflows)) + (begin + (printf "Overflow at ~a\n" n) + (loop n 5))] + [(and fuel (zero? fuel)) + (on-overflow)] + [else + ((call-with-continuation-prompt + (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda (n f) k))) + (add1 n) + (and fuel (sub1 fuel))))) + loop)])))))] + [once-k #f]) + (printf "Breaking long chain...\n") + (let ([t (thread (lambda () (long-loop void)))]) + (sleep 0.05) + (break-thread t) + (sleep) + (test #f thread-running? t)) + (printf "Trying long chain...\n") + (let ([k (long-loop (lambda () + ((let/cc k (lambda () k)))))]) + (when (procedure? k) + (set! once-k k) + (k (lambda () 17))) + (test #t procedure? once-k) + (test k values 17) + (err/rt-test (call-with-continuation-barrier + (lambda () + (once-k 18))) + exn:fail:contract:continuation?)) + (printf "Trying long chain again...\n") + (let ([k (call-with-continuation-prompt + (lambda () + (long-loop (lambda () + ((call-with-composable-continuation + (lambda (k) + (lambda () k))))))))]) + (test 18 k (lambda () 18)) + (err/rt-test (k (lambda () (/ 0))) exn:fail:contract:divide-by-zero?) + (test 45 call-with-continuation-prompt + (lambda () + (k (lambda () (abort-current-continuation + (default-continuation-prompt-tag) + (lambda () 45)))))))) + diff --git a/collects/tests/mzscheme/prompt.ss b/collects/tests/mzscheme/prompt.ss index 8a2576b0db..3e99815777 100644 --- a/collects/tests/mzscheme/prompt.ss +++ b/collects/tests/mzscheme/prompt.ss @@ -3,13 +3,11 @@ (Section 'prompt) -;;---------------------------------------- +;; ---------------------------------------- (define (test-breaks-ok) (err/rt-test (break-thread (current-thread)) exn:break?)) -(test-breaks-ok) - ;;---------------------------------------- ;; cc variants @@ -87,1674 +85,28 @@ call-with-continuation-prompt-for-composable thread-for-composable)))])) -;;---------------------------------------- -;; Prompt escapes - -;; Simple return -(test 10 call-with-continuation-prompt - (lambda () 10)) -(test-values '(10 11) (lambda () - (call-with-continuation-prompt - (lambda () (values 10 11))))) -(test-values '() (lambda () - (call-with-continuation-prompt - (lambda () (values))))) - -;; Aborts -(test 11 call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - 11)) - (default-continuation-prompt-tag) - values) -(test 11 call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () 11)))) -(test 12 call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - 12)) - (default-continuation-prompt-tag) - values) -(test 12 call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () 12))) - (default-continuation-prompt-tag)) -(test-values '(11 12) - (lambda () - (call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - 11 - 12)) - (default-continuation-prompt-tag) - values))) -(test-values '(11 12) - (lambda () - (call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () (values 11 - 12))))))) -(test 8 call-with-continuation-prompt - (lambda () (+ 17 - (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () 8))))) -(test 81 call-with-continuation-prompt - (lambda () (+ 17 - (call-with-continuation-prompt - (lambda () - (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () 81))) - (make-continuation-prompt-tag))))) -(let ([p (make-continuation-prompt-tag)]) - (test 810 call-with-continuation-prompt - (lambda () (+ 17 - (call-with-continuation-prompt - (lambda () - (abort-current-continuation - p - 810)) - (make-continuation-prompt-tag)))) - p - values)) - -;; Aborts with handler -(test 110 call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - 11)) - (default-continuation-prompt-tag) - (lambda (x) (* x 10))) -(test 23 - call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - 11 - 12)) - (default-continuation-prompt-tag) - (lambda (x y) (+ x y))) -;; Handler in tail position: -(test '(11 12 17) - 'handler-in-tail-position - (with-continuation-mark - 'x 16 - (call-with-continuation-prompt - (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - 11 - 12)) - (default-continuation-prompt-tag) - (lambda (x y) - (with-continuation-mark - 'x 17 - (list* x y - (continuation-mark-set->list - (current-continuation-marks) - 'x))))))) - -(test-breaks-ok) - -;; Abort to a prompt in a d-w post that is deeper than a -;; prompt with the same tag at the continuation-jump site: -(test 0 - values - (let ([p1 (make-continuation-prompt-tag)] - [p2 (make-continuation-prompt-tag)]) - (let/cc k - (call-with-continuation-prompt - (lambda () - (call-with-continuation-prompt - (lambda () - (dynamic-wind - void - (lambda () - (call-with-continuation-prompt - (lambda () - (k 0)) - p2)) - (lambda () - (abort-current-continuation p1 (lambda () 0))))) - p1)) - p2)))) - ;; ---------------------------------------- -;; Continuations -(with-cc-variants - (test -17 - call-with-continuation-prompt - (lambda () -17))) - -(with-cc-variants - (test 17 - call-with-continuation-prompt - (lambda () - (let/cc k - (k 17))))) - -(test-breaks-ok) - -(with-cc-variants - (test 29 - 'in-other-prompt1 - (let ([retry #f]) - (test 35 - call-with-continuation-prompt - (lambda () - (+ 18 - (let/cc k - (set! retry k) - 17)))) - (+ 1 (call-with-continuation-prompt - (lambda () - (retry 10))))))) - -(with-cc-variants - (test 60 - 'in-other-prompt2 - (let ([retry #f]) - (test 35 - call-with-continuation-prompt - (lambda () - (+ 18 - (let/cc k - (set! retry k) - 17)))) - (+ 1 (call-with-continuation-prompt - (lambda () - (+ (call-with-continuation-prompt - (lambda () - (retry 12))) - (call-with-continuation-prompt - (lambda () - (retry 11)))))))))) - -(with-cc-variants - (test '(#f #t) - 'in-other-thread1 - (let ([retry #f] - [result #f] - [did? #f]) - (call-with-continuation-prompt - (lambda () - (+ 18 - (begin0 - (let/cc k - (set! retry k) - 17) - (set! did? #t))))) - (set! did? #f) - (thread-wait - (thread (lambda () - (set! result (retry 0))))) - (list result did?)))) - -(with-cc-variants - (test 18 - 'in-other-thread2 - (let ([retry #f] - [result #f]) - (call-with-continuation-prompt - (lambda () - (+ 18 - (let/cc k - (set! retry k) - 17)))) - (thread-wait - (thread (lambda () - (set! result - (call-with-continuation-prompt - (lambda () - (retry 0))))))) - result))) - -(with-cc-variants - (test 25 - 'back-in-original-thread - (let ([retry #f] - [result #f]) - (thread-wait - (thread - (lambda () - (+ 18 - (let/cc k - (set! retry k) - 17))))) - (call-with-continuation-prompt - (lambda () - (retry 7)))))) - -(test-breaks-ok) - -;; Catch continuation in composed continuation: -(with-cc-variants - (test 89 - 'catch-composed - (let ([k (call-with-continuation-prompt - (lambda () - ((let/cc k (lambda () k)))))]) - (let ([k2 (call-with-continuation-prompt - (lambda () - (k (lambda () - (car (let/cc k2 (list k2)))))))]) - (call-with-continuation-prompt - (lambda () - (k2 '(89)))))))) - -;; Grab continuation shallow inside meta-prompt with -;; delimiting prompt deep in a different meta-prompt. -(with-cc-variants - (let ([k (call-with-continuation-prompt - (lambda () - ((call/cc - (lambda (k) (lambda () k))))))]) - (test 10 call-with-continuation-prompt - (lambda () - (let loop ([n 300]) - (if (zero? n) - (k (lambda () - (let/cc k2 (k2 10)))) - (cons n (loop (sub1 n))))))))) - -;; Grab continuation deep inside meta-prompt with -;; delimiting prompt shallow in a different meta-prompt. -(with-cc-variants - (let ([k (call-with-continuation-prompt - (lambda () - (let loop ([n 12]) - (if (zero? n) - ((call/cc - (lambda (k) (lambda () k)))) - (cons 1 (loop (sub1 n)))))))]) - (test '(1 1 1 1 1 1 1 1 1 1 1 1 . 10) call-with-continuation-prompt - (lambda () - ((list-tail k 12) - (lambda () - (let/cc k2 (k2 10)))))))) - -(test-breaks-ok) - -;; ---------------------------------------- -;; Overlapping continuations - -;; Nested -(let ([p1 (make-continuation-prompt-tag)] - [p2 (make-continuation-prompt-tag)]) - (let ([k1 #f] - [k2 #f]) - (test '(p1 p2 100) - call-with-continuation-prompt - (lambda () - (cons 'p1 - (call-with-continuation-prompt - (lambda () - (cons 'p2 - ((call/cc - (lambda (-k1) - (set! k1 -k1) - (call/cc (lambda (-k2) - (set! k2 -k2) - (lambda () '(100))) - p2)) - p1)))) - p2))) - p1) - (err/rt-test (k1) exn:fail:contract:continuation?) - (err/rt-test (k2) exn:fail:contract:continuation?) - (err/rt-test (call-with-continuation-prompt - (lambda () (k1)) - p2) - exn:fail:contract:continuation?) - (err/rt-test (call-with-continuation-prompt - (lambda () (k2)) - p1) - exn:fail:contract:continuation?) - (test '(p1 p2 101) call-with-continuation-prompt - (lambda () - (k1 (lambda () '(101)))) - p1) - (test '(p2 102) call-with-continuation-prompt - (lambda () - (k2 (lambda () '(102)))) - p2) - (test '(p1 p2 102-1) call-with-continuation-prompt - (lambda () - (k1 (lambda () (k2 (lambda () '(102-1)))))) - p1))) - -;; Use default tag to catch a meta-continuation of p1. -;; Due to different implementations of the default tag, -;; this test is interesting in the main thread and -;; a sub thread: -(let () - (define (go) - (let ([p1 (make-continuation-prompt-tag)]) - (let ([k (call-with-continuation-prompt - (lambda () - ((call/cc (lambda (k) (lambda () k)) - p1))) - p1)]) - (let ([k2 (list - (call-with-continuation-prompt - (lambda () - (k (lambda () - (let/cc k k)))) - p1))]) - (if (procedure? (car k2)) - ((car k2) 10) - (test '(10) values k2)))))) - (go) - (let ([finished #f]) - (thread-wait - (thread (lambda () - (go) - (set! finished 'finished)))) - (test 'finished values finished))) - -;; Use default tag to catch a meta-continuation of p1, -;; then catch continuation again (i.e., loop). -(let ([finished #f]) - (define (go) - (let ([p1 (make-continuation-prompt-tag)] - [counter 10]) - (let ([k (call-with-continuation-prompt - (lambda () - ((call/cc (lambda (k) (lambda () k)) - p1))) - p1)]) - (let ([k2 (list - (call-with-continuation-prompt - (lambda () - (k (lambda () - ((let/cc k (lambda () k)))))) - p1))]) - (if (procedure? (car k2)) - ((car k2) (lambda () - (if (zero? counter) - 10 - (begin - (set! counter (sub1 counter)) - ((let/cc k (lambda () k))))))) - (test '(10) values k2)) - (set! finished 'finished))))) - (go) - (let ([finished #f]) - (thread-wait - (thread (lambda () - (go) - (set! finished 'finished)))) - (test 'finished values finished))) - -;; ---------------------------------------- -;; Composable continuations - -(err/rt-test (call-with-continuation-barrier - ;; When the test is not run in a REPL but is run in the - ;; main thread, then it should fail without the barrier, - ;; too. But we don't have enough control over the test - ;; environment to assume that. - (lambda () - (call-with-composable-continuation - (lambda (x) x)))) - exn:fail:contract:continuation?) - -(err/rt-test (call-with-composable-continuation - (lambda (x) x) - (make-continuation-prompt-tag 'px)) - exn:fail:contract?) - -(let ([k (call-with-continuation-prompt - (lambda () - (call-with-composable-continuation - (lambda (k) k))))]) - (test 12 k 12) - (test 13 k (k (k (k 13)))) - (test-values '(12 13) (lambda () (k 12 13)))) - -(let ([k (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) (lambda () k))))))]) - (test 12 k (lambda () 12)) - (test-values '(12 13) (lambda () (k (lambda () (values 12 13))))) - ;; Composition shouldn't introduce a prompt: - (test 10 call-with-continuation-prompt - (lambda () - (let ([k2 (k (lambda () - (let/cc k2 k2)))]) - (if (procedure? k2) - (k2 10) - k2)))) - ;; Escape from composed continuation: - (let ([p (make-continuation-prompt-tag)]) - (test 8 call-with-continuation-prompt - (lambda () - (+ 99 (k (lambda () (abort-current-continuation p 8))))) - p - values)) - (test 8 call-with-continuation-prompt - (lambda () - (+ 99 (k (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - 8))))) - (default-continuation-prompt-tag) - values)) - -;; Etc. -(let ([k1 (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))] - [k2 (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))]) - (test 1000 - call-with-continuation-prompt - (lambda () - (k1 (lambda () (k2 (lambda () 1000)))))) - (test -1000 k1 (lambda () (k2 (lambda () -1000)))) - - (let ([k3 (call-with-continuation-prompt - (lambda () - (k1 (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))))]) - (test 1001 - call-with-continuation-prompt - (lambda () - (k3 (lambda () 1001)))) - (test -1001 k3 (lambda () -1001)) - (test 1002 - call-with-continuation-prompt - (lambda () - (k1 (lambda () (k3 (lambda () 1002)))))) - (test -1002 k1 (lambda () (k3 (lambda () -1002))))) - - (let ([k4 (call-with-continuation-prompt - (lambda () - (k1 - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))))]) - (test -1003 k4 (lambda () -1003))) - - (let ([k5 (call-with-continuation-prompt - (lambda () - ((k1 - (lambda () - (call-with-composable-continuation - (lambda (k) - (lambda () k))))))))]) - (test -1004 k5 (lambda () -1004)) - - (let ([k6 (call-with-continuation-prompt - (lambda () - ((k5 - (lambda () - (call-with-composable-continuation - (lambda (k) - (lambda () k))))))))]) - (test -1005 k6 (lambda () -1005)))) - - (let ([k7 (call-with-continuation-prompt - (lambda () - ((k1 - (lambda () - ((k1 - (lambda () - (call-with-composable-continuation - (lambda (k) - (lambda () (lambda () k))))))))))))]) - (test -1006 k7 (lambda () (lambda () -1006))) - (test '(-1007) call-with-continuation-prompt - (lambda () - (list (k7 (lambda () (lambda () -1007))))))) - - ) - -;; Check that escape drops the meta-continuation: -(test 0 - 'esc - (let ([p1 (make-continuation-prompt-tag)]) - (let/cc esc - (let ([k - (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k)) - p1))) - p1)]) - (/ (k (lambda () (esc 0)))))))) - -;; ---------------------------------------- -;; Dynamic wind - -(test 89 - 'dw - (let ([k (dynamic-wind - void - (lambda () (let ([k+e (let/cc k (cons k void))]) - ((cdr k+e) 89) - (car k+e))) - void)]) - (let/cc esc - (k (cons void esc))))) - -(let ([l null]) - (let ([k2 - (dynamic-wind - (lambda () (set! l (cons 'pre0 l))) - (lambda () - (let ([k (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (set! l (cons 'pre l))) - (lambda () (let ([k (let/cc k k)]) - k)) - (lambda () (set! l (cons 'post l))))))]) - (test '(post pre pre0) values l) - ;; Jump from one to the other: - (let ([k2 - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (set! l (cons 'pre2 l))) - (lambda () - (dynamic-wind - (lambda () (set! l (cons 'pre3 l))) - (lambda () - (let/cc k2 (k k2))) - (lambda () (set! l (cons 'post3 l))))) - (lambda () (set! l (cons 'post2 l))))))]) - (test '(post pre post2 post3 pre3 pre2 post pre pre0) values l) - k2))) - (lambda () (set! l (cons 'post0 l))))]) - (test '(post0 post pre post2 post3 pre3 pre2 post pre pre0) values l) - ;; Restore in context with fewer DWs: - (test 8 call-with-continuation-prompt (lambda () (k2 8))) - (test '(post2 post3 pre3 pre2 post0 post pre post2 post3 pre3 pre2 post pre pre0) values l) - ;; Restore in context with more DWs: - (set! l null) - (dynamic-wind - (lambda () (set! l (cons 'pre4 l))) - (lambda () - (dynamic-wind - (lambda () (set! l (cons 'pre5 l))) - (lambda () - (call-with-continuation-prompt k2)) - (lambda () (set! l (cons 'post5 l))))) - (lambda () (set! l (cons 'post4 l)))) - (test '(post4 post5 post2 post3 pre3 pre2 pre5 pre4) values l))) - -;; Like the meta-continuation test above, but add a dynamic wind -;; to be restored in the p1 continuation: -(let ([p1 (make-continuation-prompt-tag)] - [did #f]) - (let ([k (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () - (set! did 'in)) - (lambda () - ((call/cc (lambda (k) (lambda () k)) - p1))) - (lambda () - (set! did 'out)))) - p1)]) - (set! did #f) - (let ([k2 (list - (call-with-continuation-prompt - (lambda () - (k (lambda () - (test 'in values did) - ((let/cc k (lambda () k)))))) - p1))]) - (test 'out values did) - (if (procedure? (car k2)) - ((car k2) (lambda () - (test 'in values did) - 10)) - (test '(10) values k2))))) - -;; Composable continuations -(let ([l null]) - (let ([k2 - (dynamic-wind - (lambda () (set! l (cons 'pre0 l))) - (lambda () - (let ([k (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (set! l (cons 'pre l))) - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))) - (lambda () (set! l (cons 'post l))))))]) - (test '(post pre pre0) values l) - (test 12 k (lambda () 12)) - (test '(post pre post pre pre0) values l) - k)) - (lambda () (set! l (cons 'post0 l))))]) - (test '(post0 post pre post pre pre0) values l) - (test 73 k2 (lambda () 73)) - (test '(post pre post0 post pre post pre pre0) values l) - (set! l null) - ;; Add d-w inside k2: - (let ([k3 (call-with-continuation-prompt - (lambda () - (k2 (lambda () - (dynamic-wind - (lambda () (set! l (cons 'pre2 l))) - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))) - (lambda () (set! l (cons 'post2 l))))))))]) - (test '(post post2 pre2 pre) values l) - (test 99 k3 (lambda () 99)) - (test '(post post2 pre2 pre post post2 pre2 pre) values l)) - (set! l null) - ;; Add d-w outside k2: - (let ([k4 (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (set! l (cons 'pre2 l))) - (lambda () - (k2 (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))) - (lambda () (set! l (cons 'post2 l))))))]) - (test '(post2 post pre pre2) values l) - (test 99 k4 (lambda () 99)) - (test '(post2 post pre pre2 post2 post pre pre2) values l)))) - -;; Jump back into post: -(let ([l null] - [p1 (make-continuation-prompt-tag)] - [p2 (make-continuation-prompt-tag)] - [k2 #f]) - (define (out v) (set! l (cons v l))) - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (out 'pre)) - (lambda () - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (out 'pre2)) - (lambda () (void)) - (lambda () - (call/cc (lambda (k) - (set! k2 k)) - p2) - (out 'post2)))) - p2)) - (lambda () (out 'post1)))) - p1) - (call-with-continuation-prompt - (lambda () - (k2 10)) - p2) - (test '(post2 post1 post2 pre2 pre) values l)) - -;; Jump into post, then back out -(let ([l null] - [p1 (make-continuation-prompt-tag)] - [p2 (make-continuation-prompt-tag)] - [k2 #f] - [count 0]) - (define (out v) (set! l (cons v l))) - (let/cc esc - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (out 'pre1)) - (lambda () - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (out 'pre2)) - (lambda () (void)) - (lambda () - (call/cc (lambda (k) - (set! k2 k)) - p2) - (out 'post2) - (esc)))) - p2)) - (lambda () (out 'post1)))) - p1)) - (printf "here ~a\n" count) - (set! count (add1 count)) - (unless (= count 3) - (call-with-continuation-prompt - (lambda () - (k2 10)) - p2)) - (test '(post2 post2 post1 post2 pre2 pre1) values l)) - -(printf "into post from escape\n") - -;; Jump into post from an escape, rather than -;; from a result continuation -(let ([l null] - [p1 (make-continuation-prompt-tag)] - [p2 (make-continuation-prompt-tag)] - [k2 #f] - [count 0]) - (define (out v) (set! l (cons v l))) - (let/cc esc - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (out 'pre1)) - (lambda () - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (out 'pre2)) - (lambda () (esc)) - (lambda () - (call/cc (lambda (k) - (set! k2 k)) - p2) - (out 'post2)))) - p2)) - (lambda () (out 'post1)))) - p1)) - (set! count (add1 count)) - (unless (= count 3) - (call-with-continuation-prompt - (lambda () - (k2 10)) - p2)) - (test '(post2 post2 post1 post2 pre2 pre1) values l)) - -;; ---------------------------------------- -;; Continuation marks - -(let ([go - (lambda (access-tag catch-tag blocked?) - (let ([k (call-with-continuation-prompt - (lambda () - (with-continuation-mark - 'x - 17 - ((call/cc (lambda (k) (lambda () k)) - catch-tag)))) - catch-tag)]) - (with-continuation-mark - 'x - 18 - (with-continuation-mark - 'y - 8 - (begin - (printf "here\n") - (test 18 continuation-mark-set-first #f 'x #f catch-tag) - (test '(18) continuation-mark-set->list (current-continuation-marks catch-tag) 'x catch-tag) - (test 17 - call-with-continuation-prompt - (lambda () - (k (lambda () (continuation-mark-set-first #f 'x #f catch-tag)))) - catch-tag) - (test 8 - call-with-continuation-prompt - (lambda () - (k (lambda () (continuation-mark-set-first #f 'y #f catch-tag)))) - catch-tag) - (test (if blocked? - '(17) - '(17 18)) - call-with-continuation-prompt - (lambda () - (k (lambda () (continuation-mark-set->list (current-continuation-marks access-tag) - 'x access-tag)))) - catch-tag) - (test '(17) - continuation-mark-set->list (continuation-marks k catch-tag) 'x catch-tag) - (test (if blocked? - '() - '(8)) - call-with-continuation-prompt - (lambda () - (k (lambda () (continuation-mark-set->list (current-continuation-marks access-tag) - 'y access-tag)))) - catch-tag) - - 'done)))))]) - (go (default-continuation-prompt-tag) (default-continuation-prompt-tag) #t) - (let ([p2 (make-continuation-prompt-tag 'p2)]) - (call-with-continuation-prompt - (lambda () - (go p2 p2 #t) - (go p2 (default-continuation-prompt-tag) #f) - (go (default-continuation-prompt-tag) p2 #f)) - p2))) - -(define (non-tail v) (values v)) - -(let () - (define (go access-tag blocked?) - (let ([k (call-with-continuation-prompt - (lambda () - (with-continuation-mark - 'x - 71 - ((call-with-composable-continuation - (lambda (k) - (lambda () k)))))))]) - (test #f continuation-mark-set-first #f 'x) - (test 71 k (lambda () (continuation-mark-set-first #f 'x))) - (test '(71) continuation-mark-set->list (continuation-marks k) 'x) - (test 71 'wcm (with-continuation-mark - 'x 81 - (k (lambda () (continuation-mark-set-first #f 'x))))) - (test '(71 81) 'wcm (with-continuation-mark - 'x 81 - (non-tail - (k (lambda () - (continuation-mark-set->list (current-continuation-marks) 'x)))))) - (test '(71) 'wcm (with-continuation-mark - 'x 81 - (k (lambda () - (continuation-mark-set->list (current-continuation-marks) 'x))))) - (test '(91 71 81) 'wcm (with-continuation-mark - 'x 81 - (non-tail - (k (lambda () - (non-tail - (with-continuation-mark - 'x 91 - (continuation-mark-set->list (current-continuation-marks) 'x)))))))) - (test '(91 81) 'wcm (with-continuation-mark - 'x 81 - (non-tail - (k (lambda () - (with-continuation-mark - 'x 91 - (continuation-mark-set->list (current-continuation-marks) 'x))))))) - (test '(91) 'wcm (with-continuation-mark - 'x 81 - (k (lambda () - (with-continuation-mark - 'x 91 - (continuation-mark-set->list (current-continuation-marks) 'x)))))) - (let ([k2 (with-continuation-mark - 'x 101 - (call-with-continuation-prompt - (lambda () - (with-continuation-mark - 'x 111 - (non-tail - (k (lambda () - ((call-with-composable-continuation - (lambda (k2) - (test (if blocked? - '(71 111) - '(71 111 101)) - continuation-mark-set->list (current-continuation-marks access-tag) - 'x access-tag) - (lambda () k2)))))))))))]) - (test '(71 111) continuation-mark-set->list (continuation-marks k2) 'x) - (test '(71 111) k2 (lambda () - (continuation-mark-set->list (current-continuation-marks) 'x))) - (test 71 k2 (lambda () - (continuation-mark-set-first #f 'x))) - (test '(71 111 121) 'wcm (with-continuation-mark - 'x 121 - (non-tail - (k2 (lambda () - (continuation-mark-set->list (current-continuation-marks) 'x)))))) - ) - - (let ([k2 (with-continuation-mark - 'x 101 - (call-with-continuation-prompt - (lambda () - (with-continuation-mark - 'x 111 - (k (lambda () - ((call-with-composable-continuation - (lambda (k2) - (test (if blocked? - '(71) - '(71 101)) - continuation-mark-set->list (current-continuation-marks access-tag) - 'x access-tag) - (lambda () k2))))))))))]) - (test '(71) continuation-mark-set->list (continuation-marks k2) 'x) - (test '(71) k2 (lambda () - (continuation-mark-set->list (current-continuation-marks) 'x))) - (test 71 k2 (lambda () - (continuation-mark-set-first #f 'x))) - (test '(71 121) 'wcm (with-continuation-mark - 'x 121 - (non-tail - (k2 (lambda () - (continuation-mark-set->list (current-continuation-marks) 'x))))))))) - (go (default-continuation-prompt-tag) #t) - (let ([p2 (make-continuation-prompt-tag 'p2)]) - (call-with-continuation-prompt - (lambda () - (go p2 #f)) - p2))) - -;; Check interaction of dynamic winds, continuation composition, and continuation marks -(let ([pre-saw-xs null] - [post-saw-xs null] - [pre-saw-ys null] - [post-saw-ys null]) - (let ([k (call-with-continuation-prompt - (lambda () - (with-continuation-mark - 'x - 77 - (dynamic-wind - (lambda () - (set! pre-saw-xs (continuation-mark-set->list (current-continuation-marks) 'x)) - (set! pre-saw-ys (continuation-mark-set->list (current-continuation-marks) 'y))) - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))) - (lambda () - (set! post-saw-xs (continuation-mark-set->list (current-continuation-marks) 'x)) - (set! post-saw-ys (continuation-mark-set->list (current-continuation-marks) 'y)))))))]) - (test '(77) values pre-saw-xs) - (test '() values pre-saw-ys) - (test '(77) values post-saw-xs) - (test '() values post-saw-ys) - (let ([jump-in - (lambda (wrap r-val y-val) - (test r-val 'wcm - (wrap - (lambda (esc) - (with-continuation-mark - 'y y-val - (k (lambda () (esc))))))) - (test '(77) values pre-saw-xs) - (test (list y-val) values pre-saw-ys) - (test '(77) values post-saw-xs) - (test (list y-val) values post-saw-ys) - (let ([k3 (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))]) - (test r-val 'wcm - (wrap - (lambda (esc) - (k3 - (lambda () - (with-continuation-mark - 'y y-val - (k (lambda () (k3 (lambda () (esc)))))))))))))]) - (jump-in (lambda (f) (f (lambda () 10))) 10 88) - (jump-in (lambda (f) (let/cc esc (f (lambda () (esc 20))))) 20 99) - (printf "here\n") - (jump-in (lambda (f) - (let ([p1 (make-continuation-prompt-tag)]) - (call-with-continuation-prompt - (lambda () - (f (lambda () (abort-current-continuation p1 (lambda () 30))))) - p1))) - 30 111) - (void)))) - -;; Tail meta-calls should overwrite continuation marks -(let ([k (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))]) - (with-continuation-mark - 'n #f - (let loop ([n 10]) - (unless (zero? n) - (with-continuation-mark - 'n n - (k (lambda () - (test (list n) continuation-mark-set->list (current-continuation-marks) 'n) - (loop (sub1 n))))))))) - -;; Tail meta-calls should propagate cont marks -(let ([k (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))]) - (with-continuation-mark - 'n 10 - (let loop ([n 10]) - (test n continuation-mark-set-first #f 'n) - (test (list n) continuation-mark-set->list (current-continuation-marks) 'n) - (unless (zero? n) - (k (lambda () - (with-continuation-mark - 'n (sub1 n) - (loop (sub1 n))))))))) - -;; Captured mark should replace installed mark -(let ([k (call-with-continuation-prompt - (lambda () - (with-continuation-mark - 'n #t - ((call-with-composable-continuation - (lambda (k) - (lambda () k)))))))]) - (with-continuation-mark - 'n #f - (let loop ([n 10]) - (unless (zero? n) - (with-continuation-mark - 'n n - (k (lambda () - (test (list #t) continuation-mark-set->list (current-continuation-marks) 'n) - (test #t continuation-mark-set-first #f 'n) - (loop (sub1 n))))))))) - -;; ---------------------------------------- -;; Olivier Danvy's traversal - -;; Shift & reset via composable and abort -(let () - (define traverse - (lambda (xs) - (letrec ((visit - (lambda (xs) - (if (null? xs) - '() - (visit (call-with-composable-continuation - (lambda (k) - (abort-current-continuation - (default-continuation-prompt-tag) - (let ([v (cons (car xs) - (call-with-continuation-prompt - (lambda () - (k (cdr xs)))))]) - (lambda () v)))))))))) - (call-with-continuation-prompt - (lambda () - (visit xs)))))) - (test '(1 2 3 4 5) traverse '(1 2 3 4 5))) - -;; Shift & reset using composable and call/cc -(let () - (define call-in-application-context - (call-with-continuation-prompt - (lambda () - ((call-with-current-continuation - (lambda (k) (lambda () k))))))) - (define traverse - (lambda (xs) - (letrec ((visit - (lambda (xs) - (if (null? xs) - '() - (visit (call-with-composable-continuation - (lambda (k) - (call-in-application-context - (lambda () - (cons (car xs) - (call-with-continuation-prompt - (lambda () - (k (cdr xs)))))))))))))) - (call-with-continuation-prompt - (lambda () - (visit xs)))))) - (test '(1 2 3 4 5) traverse '(1 2 3 4 5))) - -;; control and prompt using composable and abort -(let () - (define traverse - (lambda (xs) - (letrec ((visit - (lambda (xs) - (if (null? xs) - (list-tail '() 0) - (visit (call-with-composable-continuation - (lambda (k) - (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () - (cons (car xs) - (k (cdr xs)))))))))))) - (call-with-continuation-prompt - (lambda () - (visit xs)))))) - (test '(5 4 3 2 1) traverse '(1 2 3 4 5))) - -;; control and prompt using composable and call/cc -(let () - (define call-in-application-context - (call-with-continuation-prompt - (lambda () - ((call-with-current-continuation - (lambda (k) (lambda () k))))))) - (define traverse - (lambda (xs) - (letrec ((visit - (lambda (xs) - (if (null? xs) - (list-tail '() 0) - (visit (call-with-composable-continuation - (lambda (k) - (call-in-application-context - (lambda () - (cons (car xs) - (k (cdr xs)))))))))))) - (call-with-continuation-prompt - (lambda () - (visit xs)))))) - (test '(5 4 3 2 1) traverse '(1 2 3 4 5))) - -;; ---------------------------------------- -;; Check unwinding of runstack overflows on prompt escape - -(let ([try - (lambda (thread m-top n-top do-mid-stream do-abort) - (let ([result #f]) - (thread-wait - (thread - (lambda () - (set! result - (let pre-loop ([m m-top]) - (if (zero? m) - (list - (do-mid-stream - (lambda () - (call-with-continuation-prompt - (lambda () - (let loop ([n n-top]) - (if (zero? n) - (do-abort - (lambda () - (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () 5000)))) - (+ (loop (sub1 n)))))))))) - (list (car (pre-loop (sub1 m)))))))))) - (test '(5000) values result)))]) - (try thread 5000 10000 (lambda (mid) (mid)) (lambda (abort) (abort))) - (try thread 5000 10000 (lambda (mid) (mid)) - (lambda (abort) ((call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) (lambda () k)))))) - (lambda () 5000)))) - (try thread 5000 10000 (lambda (mid) (mid)) - (lambda (abort) ((call-with-continuation-prompt - (lambda () - ((call/cc - (lambda (k) (lambda () k)))))) - (lambda () 5000)))) - (try thread 5000 10000 (lambda (mid) (mid)) - (lambda (abort) (((call/cc - (lambda (k) (lambda () k)))) - (lambda () (lambda (x) 5000))))) - (try thread 5000 10000 - (lambda (mid) (call-with-continuation-barrier mid)) - (lambda (abort) (((call/cc - (lambda (k) (lambda () k)))) - (lambda () (lambda (x) 5000))))) - (let ([p (make-continuation-prompt-tag 'p)]) - (try (lambda (f) - (thread - (lambda () - (call-with-continuation-prompt f p)))) - 5000 10000 - (lambda (mid) (mid)) - (lambda (abort) - ((call/cc - (lambda (k) - (thread-wait (thread - (lambda () - (call-with-continuation-prompt - (lambda () - (k abort)) - p)))) - (lambda () (abort-current-continuation p void))) - p))))) - ) - -(test-breaks-ok) - -;; ---------------------------------------- -;; Some repeats, but ensure a continuation prompt -;; and check d-w interaction. - -(let ([output null]) - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (set! output (cons 'in output))) - (lambda () - (let ([finished #f]) - (define (go) - (let ([p1 (make-continuation-prompt-tag)] - [counter 10]) - (let ([k (call-with-continuation-prompt - (lambda () - ((call/cc (lambda (k) (lambda () k)) - p1))) - p1)]) - (let ([k2 (list - (call-with-continuation-prompt - (lambda () - (k (lambda () - ((let/cc k (lambda () k)))))) - p1))]) - (current-milliseconds) - (if (procedure? (car k2)) - ((car k2) (lambda () - (if (zero? counter) - 10 - (begin - (set! counter (sub1 counter)) - ((let/cc k (lambda () k))))))) - (values '(10) values k2)) - (set! finished 'finished))))) - (go))) - (lambda () (set! output (cons 'out output))))) - (default-continuation-prompt-tag) - void) - (test '(out in) values output)) - -(let ([output null]) - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (set! output (cons 'in output))) - (lambda () - (let ([p1 (make-continuation-prompt-tag)]) - (let/cc esc - (let ([k - (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k)) - p1))) - p1)]) - (/ (k (lambda () (esc 0)))))))) - (lambda () (set! output (cons 'out output))))) - (default-continuation-prompt-tag) - void) - (test '(out in) values output)) - -;;---------------------------------------- -;; tests invoking delimited captures in dynamic-wind pre- and post-thunks - -;; Arrange for a post-thunk to remove a target -;; for an escape: -(err/rt-test - (let ([p1 (make-continuation-prompt-tag 'p1)] - [exit-k #f]) - (let ([x (let/ec esc - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (void)) - (lambda () (esc 'done)) - (lambda () - ((call/cc - (lambda (k) - (set! exit-k k) - (lambda () 10)) - p1)) - (printf "post\n")))) - p1))]) - (call-with-continuation-barrier - (lambda () - (call-with-continuation-prompt - (lambda () - (exit-k (lambda () 'hi))) - p1))))) - exn:fail:contract:continuation?) - -;; Same thing, but escape via prompt: -(err/rt-test - (let ([p1 (make-continuation-prompt-tag 'p1)] - [p2 (make-continuation-prompt-tag 'p2)] - [output null] - [exit-k #f]) - (let ([x (call-with-continuation-prompt - (lambda () - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (void)) - (lambda () (abort-current-continuation p2 1 2 3)) - (lambda () - ((call/cc - (lambda (k) - (set! exit-k k) - (lambda () 10)) - p1)) - (set! output (cons 'post output))))) - p1)) - p2 - void)]) - (call-with-continuation-barrier - (lambda () - (call-with-continuation-prompt - (lambda () - (exit-k (lambda () 'hi))) - p1))))) - exn:fail:contract?) - -;; Arrange for a barrier to interfere with a continuation -;; jump after dynamic-winds are already being processed: -(let ([p1 (make-continuation-prompt-tag 'p1)] - [output null] - [exit-k #f]) - (let ([go - (lambda (launch) - (let ([k (let/cc esc - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (void)) - (lambda () - (with-handlers ([void (lambda (exn) - (test #f "should not be used!" #t))]) - (launch esc))) - (lambda () - ((call/cc - (lambda (k) - (set! exit-k k) - (lambda () 10)) - p1)) - (set! output (cons 'post output))))) - p1))]) - (call-with-continuation-barrier - (lambda () - (call-with-continuation-prompt - (lambda () - (exit-k (lambda () 'hi))) - p1)))))]) - (err/rt-test - (go (lambda (esc) (esc 'middle))) - exn:fail:contract:continuation?) - (test '(post post) values output) - (let ([meta (call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) (lambda () k))))))]) - (err/rt-test - (go (lambda (esc) - (meta - (lambda () (esc 'ok))))) - exn:fail:contract:continuation?)) - (test '(post post post post) values output))) - -;; Similar, but more checking of dropped d-ws: -(let ([p1 (make-continuation-prompt-tag 'p1)] - [output null] - [exit-k #f] - [done? #f]) - ;; Capture a continuation w.r.t. the default prompt tag: - (call/cc - (lambda (esc) - (dynamic-wind - (lambda () (void)) - (lambda () - ;; Set a prompt for tag p1: - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (void)) - ;; inside d-w, jump out: - (lambda () (esc 'done)) - (lambda () - ;; As we jump out, capture a continuation - ;; w.r.t. p1: - ((call/cc - (lambda (k) - (set! exit-k k) - (lambda () 10)) - p1)) - (set! output (cons 'inner output))))) - p1)) - (lambda () - ;; This post thunk is not in the - ;; delimited continuation captured - ;; via tag p1: - (set! output (cons 'outer output)))))) - (unless done? - (set! done? #t) - ;; Now invoke the delimited continuation, which must - ;; somehow continue the jump to `esc': - (call-with-continuation-prompt - (lambda () - (exit-k (lambda () 10))) - p1)) - (test '(inner outer inner) values output)) - -;; Again, more checking of output -(let ([p1 (make-continuation-prompt-tag 'p1)] - [p2 (make-continuation-prompt-tag 'p2)] - [output null] - [exit-k #f]) - ;; Set up a prompt tp jump to: - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (void)) - (lambda () - ;; Set a prompt for tag p1: - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () (void)) - ;; inside d-w, jump out: - (lambda () (abort-current-continuation - p2 - "done")) - (lambda () - ;; As we jump out, capture a continuation - ;; w.r.t. p1: - ((call/cc - (lambda (k) - (set! exit-k k) - (lambda () 10)) - p1)) - (set! output (cons 'inner output))))) - p1)) - (lambda () - ;; This post thunk is not in the - ;; delimited continuation captured - ;; via tag p1: - (set! output (cons 'outer output))))) - p2 - (lambda (v) - (set! output (cons 'orig output)))) - ;; Now call, redirecting the escape to here: - (call-with-continuation-prompt - (lambda () - (call-with-continuation-prompt - (lambda () - (exit-k (lambda () 10))) - p1)) - p2 - (lambda (v) - (set! output (cons 'new output)))) - (test '(new inner orig outer inner) values output)) - -;; abort past a tag -(test 10 - values - (let ([p1 (make-continuation-prompt-tag)] - [p2 (make-continuation-prompt-tag)]) - (call-with-continuation-prompt - (lambda () - (call/cc - (lambda (k) - (call-with-continuation-prompt - (lambda () - (k 10)) - p2)) - p1)) - p1))) - -;; Check that a prompt is not somehow tied to its original -;; barrier, so that jumps are not allowed when they should -;; be: -(test 0 - values - (let ([p1 (make-continuation-prompt-tag 'p1)] - [p2 (make-continuation-prompt-tag 'p2)]) - (let ([k (call-with-continuation-prompt - (lambda () - (call-with-continuation-prompt - (lambda () - ((call-with-current-continuation - (lambda (k) (lambda () k)) - p2))) - p1)) - p2)]) - (call-with-continuation-barrier - (lambda () - (call-with-continuation-barrier - (lambda () - (let ([k1 - (call-with-continuation-prompt - (lambda () - (k - (lambda () - ;; prompt for p1 has been restored - (call/cc (lambda (k1) k1) p1)))) - p2)]) - (call-with-continuation-prompt - (lambda () - (k1 0)) - p1))))))))) - -(test 12 - values - (let ([p1 (make-continuation-prompt-tag 'p1)]) - (let ([k (call-with-continuation-barrier - (lambda () - (call-with-continuation-prompt - (lambda () - ((call-with-current-continuation - (lambda (k) (lambda () k)) - p1))) - p1)))]) - (call-with-continuation-barrier - (lambda () - (call-with-continuation-barrier - (lambda () - (call-with-continuation-barrier - (lambda () - (call-with-continuation-prompt - (lambda () - (let/cc w - (call-with-continuation-prompt - (lambda () - (k (lambda () (w 12)))) - p1))))))))))))) - -;; ---------------------------------------- -;; Try long chain of composable continuations - -(let ([long-loop - (lambda (on-overflow) - (let ([v (make-vector 6)]) - (vector-set-performance-stats! v) - (let ([overflows (vector-ref v 5)]) - ;; Although this is a constant-space loop, the implementation - ;; pushes each captured continuation further and further down - ;; the C stack. Eventually, the relevant segment wraps around, - ;; with an overflow. Push a little deeper and then capture - ;; that. - (let loop ([n 0][fuel #f]) - (vector-set-performance-stats! v) - (cond - [(and (not fuel) - ((vector-ref v 5) . > . overflows)) - (begin - (printf "Overflow at ~a\n" n) - (loop n 5))] - [(and fuel (zero? fuel)) - (on-overflow)] - [else - ((call-with-continuation-prompt - (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda (n f) k))) - (add1 n) - (and fuel (sub1 fuel))))) - loop)])))))] - [once-k #f]) - (printf "Breaking long chain...\n") - (let ([t (thread (lambda () (long-loop void)))]) - (sleep 0.05) - (break-thread t) - (sleep) - (test #f thread-running? t)) - (printf "Trying long chain...\n") - (let ([k (long-loop (lambda () - ((let/cc k (lambda () k)))))]) - (when (procedure? k) - (set! once-k k) - (k (lambda () 17))) - (test #t procedure? once-k) - (test k values 17) - (err/rt-test (call-with-continuation-barrier - (lambda () - (once-k 18))) - exn:fail:contract:continuation?)) - (printf "Trying long chain again...\n") - (let ([k (call-with-continuation-prompt - (lambda () - (long-loop (lambda () - ((call-with-composable-continuation - (lambda (k) - (lambda () k))))))))]) - (test 18 k (lambda () 18)) - (err/rt-test (k (lambda () (/ 0))) exn:fail:contract:divide-by-zero?) - (test 45 call-with-continuation-prompt - (lambda () - (k (lambda () (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () 45)))))))) +(load-relative "prompt-tests.ss") ;; ---------------------------------------- -(unless (namespace-variable-value 'running-prompt-tests-in-thread? #f (lambda () #f)) - ;; Run the whole thing in a thread with no prompts around evaluation. - ;; This tests the special case of the implicit prompt at the start - ;; of a thread. - (thread-wait - (thread - (lambda () - (namespace-set-variable-value! 'running-prompt-tests-in-thread? #t) - (let ([p (open-input-file (build-path - (or (current-load-relative-directory) - (current-directory)) - "prompt.ss"))]) - (let loop () - (let ([r (read-syntax (object-name p) p)]) - (unless (eof-object? r) - (eval r) - (loop))))))))) +;; Run the whole thing in a thread with no prompts around evaluation. +;; This tests the special case of the implicit prompt at the start +;; of a thread. +(thread-wait + (thread + (lambda () + (namespace-set-variable-value! 'running-prompt-tests-in-thread? #t) + (let ([p (open-input-file (build-path + (or (current-load-relative-directory) + (current-directory)) + "prompt-tests.ss"))]) + (let loop () + (let ([r (read-syntax (object-name p) p)]) + (unless (eof-object? r) + (eval r) + (loop)))))))) ;; ---------------------------------------- diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index 33cfac9e43..71ebc1ce0c 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1,6 +1,8 @@ (load-relative "loadtest.ss") +;; ---------------------------------------- + (test 0 'with-handlers (with-handlers () 0)) (test 1 'with-handlers (with-handlers ([void void]) 1)) (test 2 'with-handlers (with-handlers ([void void]) 1 2)) @@ -1075,6 +1077,45 @@ (let ([x (cons 1 2)]) (let ([f (lambda (x) x)]) (f (lambda (y) x)))) 10) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check #%top-interaction + +(module quoting-top-interaction mzscheme + (provide (all-from-except mzscheme #%top-interaction) + (rename top-interaction #%top-interaction)) + (define-syntax top-interaction + (syntax-rules () + [(_ . e) (quote e)]))) + +(dynamic-require 'quoting-top-interaction #f) +(let ([ns (make-namespace 'empty)]) + (namespace-attach-module (current-namespace) 'quoting-top-interaction ns) + (parameterize ([current-namespace ns]) + (namespace-require 'quoting-top-interaction)) + (test 3 'non-top + (parameterize ([current-namespace ns]) + (eval '(+ 1 2)))) + (test '(+ 1 2) 'repl-top + (let ([s (open-output-bytes)]) + (parameterize ([current-input-port (open-input-string "(+ 1 2)")] + [current-namespace ns] + [current-output-port s]) + (read-eval-print-loop)) + (let ([p (open-input-bytes (get-output-bytes s))]) + (read p) + (read p)))) + (let ([tmp-file "tmp1"]) + (with-output-to-file tmp-file (lambda () (display '(+ 1 2))) 'truncate/replace) + (test '(+ 1 2) 'repl-top + (parameterize ([current-namespace ns]) + (load tmp-file))) + (with-output-to-file tmp-file (lambda () (display '(module tmp1 mzscheme (provide x) (define x 12)))) + 'truncate/replace) + (test 12 'module + (parameterize ([current-namespace ns]) + (dynamic-require (build-path (current-directory) tmp-file) 'x))) + (delete-file tmp-file))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs)