unit clean-up
svn: r5160
This commit is contained in:
parent
343e226df1
commit
7b13755dad
|
@ -1,62 +1,10 @@
|
||||||
(module browser-sig mzscheme
|
(module browser-sig mzscheme
|
||||||
(require (lib "unit.ss"))
|
(require (lib "unit.ss")
|
||||||
|
"private/sig.ss")
|
||||||
|
|
||||||
(provide relative-btree^
|
(provide browser^)
|
||||||
bullet-export^
|
|
||||||
hyper^
|
|
||||||
html-export^
|
|
||||||
html^)
|
|
||||||
|
|
||||||
(define-signature html-export^
|
(define-signature browser^
|
||||||
(html-img-ok
|
|
||||||
html-eval-ok
|
|
||||||
image-map-snip%))
|
|
||||||
|
|
||||||
(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^
|
|
||||||
((open hyper^)
|
((open hyper^)
|
||||||
(open html-export^)
|
(open html-export^)
|
||||||
(open bullet-export^))))
|
(open bullet-export^))))
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
(lib "url-sig.ss" "net")
|
(lib "url-sig.ss" "net")
|
||||||
(lib "url-unit.ss" "net")
|
(lib "url-unit.ss" "net")
|
||||||
"browser-sig.ss"
|
"browser-sig.ss"
|
||||||
|
"private/sig.ss"
|
||||||
"private/bullet.ss"
|
"private/bullet.ss"
|
||||||
"private/html.ss"
|
"private/html.ss"
|
||||||
"private/hyper.ss")
|
"private/hyper.ss")
|
||||||
|
@ -14,10 +15,24 @@
|
||||||
|
|
||||||
(define-unit-from-context bullet@ bullet-export^)
|
(define-unit-from-context bullet@ bullet-export^)
|
||||||
|
|
||||||
(define-compound-unit/infer browser@
|
(define-compound-unit/infer pre-browser@
|
||||||
(import setup:plt-installer^
|
(import setup:plt-installer^
|
||||||
mred^
|
mred^
|
||||||
url^)
|
url^)
|
||||||
(export hyper^ html-export^ bullet-export^)
|
(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^)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -10,6 +10,6 @@
|
||||||
"browser-sig.ss"
|
"browser-sig.ss"
|
||||||
"browser-unit.ss")
|
"browser-unit.ss")
|
||||||
|
|
||||||
(provide-signature-elements hyper^ html-export^ bullet-export^)
|
(provide-signature-elements browser^)
|
||||||
|
|
||||||
(define-values/invoke-unit/infer browser@))
|
(define-values/invoke-unit/infer browser@))
|
||||||
|
|
|
@ -360,8 +360,8 @@ matching the following signatures:
|
||||||
|
|
||||||
setup:plt-installer^
|
setup:plt-installer^
|
||||||
mred^
|
mred^
|
||||||
net:tcp^ (see "tcp-sig.ss" in the "net" collection)
|
tcp^ (see "tcp-sig.ss" in the "net" collection)
|
||||||
net:url^ (see "url-sig.ss" in the "url" collection)
|
url^ (see "url-sig.ss" in the "url" collection)
|
||||||
|
|
||||||
It exports the browser^ signature.
|
It exports the browser^ signature.
|
||||||
|
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
(require (lib "unit.ss")
|
(require (lib "unit.ss")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
"browser-sig.ss"
|
"browser-sig.ss"
|
||||||
|
"private/sig.ss"
|
||||||
"private/html.ss"
|
"private/html.ss"
|
||||||
"private/bullet.ss"
|
"private/bullet.ss"
|
||||||
(lib "url.ss" "net")
|
(lib "url.ss" "net")
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
(module btree (lib "a-unit.ss")
|
(module btree (lib "a-unit.ss")
|
||||||
(require "../browser-sig.ss")
|
(require "sig.ss")
|
||||||
|
|
||||||
;; Implements a red-black tree with relative indexing along right
|
;; Implements a red-black tree with relative indexing along right
|
||||||
;; splines. This allows the usual O(log(n)) operations, plus a
|
;; splines. This allows the usual O(log(n)) operations, plus a
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
(module html (lib "a-unit.ss")
|
(module html (lib "a-unit.ss")
|
||||||
(require "../browser-sig.ss"
|
(require "sig.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "etc.ss")
|
(lib "etc.ss")
|
||||||
|
|
|
@ -30,7 +30,7 @@ A test case:
|
||||||
|
|
||||||
(module hyper (lib "a-unit.ss")
|
(module hyper (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"../browser-sig.ss"
|
"sig.ss"
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "string.ss")
|
(lib "string.ss")
|
||||||
|
|
|
@ -249,8 +249,9 @@ _option.ss_ module. Options are set by the following parameters:
|
||||||
> propagate-constants - #t improves the code by
|
> propagate-constants - #t improves the code by
|
||||||
propagating constants. Default = #t.
|
propagating constants. Default = #t.
|
||||||
|
|
||||||
> assume-primitives - #t equates X with #%X when
|
> assume-primitives - #t adds `(require mzscheme)'
|
||||||
#%X exists. This is useful only with non-unitized code.
|
to the beginning of the program. This is useful only
|
||||||
|
with non-`module' code.
|
||||||
Default = #f.
|
Default = #f.
|
||||||
|
|
||||||
> stupid - Allow obvious non-syntactic errors; e.g.:
|
> 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
|
> vehicles - Controls how closures are compiled. The
|
||||||
possible values are: 'vehicles:automatic - auto-groups
|
possible values are: 'vehicles:automatic - auto-groups
|
||||||
'vehicles:functions - groups by procedure
|
'vehicles:functions - groups by procedure
|
||||||
'vehicles:units - groups by unit
|
'vehicles:units - usupported
|
||||||
'vehicles:monolithic - groups randomly
|
'vehicles:monolithic - groups randomly
|
||||||
Default = 'vehicles:automatic.
|
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
|
and linker that are used. See doc.txt in the `dynext' collection for
|
||||||
more information about those options.
|
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^
|
> compiler:option^
|
||||||
which contains these options. The _sig.ss_ library defines the
|
which contains these options. The _sig.ss_ library defines the
|
||||||
`compiler:option^' signature.
|
`compiler:option^' signature.
|
||||||
|
@ -297,9 +298,9 @@ which contains these options. The _sig.ss_ library defines the
|
||||||
The Compiler as a Unit
|
The Compiler as a Unit
|
||||||
======================
|
======================
|
||||||
|
|
||||||
The _compiler-unit.ss_ library provides a unit/sig
|
The _compiler-unit.ss_ library provides a unit
|
||||||
> compiler@
|
> compiler@
|
||||||
matching the signature
|
exporting the signature
|
||||||
> compiler^
|
> compiler^
|
||||||
which provides the compiler.ss functions. This signature and all
|
which provides the compiler.ss functions. This signature and all
|
||||||
auxiliary signatures needed by compiler@ are defined by the
|
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
|
The high-level compiler.ss interface relies on low-level
|
||||||
implementations of the extension compiler and linker.
|
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,
|
low-level extension compiler and multi-file linker,
|
||||||
> ld@
|
> ld@
|
||||||
and
|
and
|
||||||
|
@ -359,7 +360,7 @@ The low-level linker functions from ld@ are:
|
||||||
compiled object and .kp files into a multi-file extension.
|
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:compile^ - From the `dynext' collection
|
||||||
dynext:link^
|
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
|
be `load'ed directly by a running program, as long as the
|
||||||
`read-accept-compiled' parameter is true.
|
`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
|
that imports nothing and exports the functions below. The
|
||||||
_embedr-sig.ss_ library provides the signature, _compiler:embed^_.
|
_embedr-sig.ss_ library provides the signature, _compiler:embed^_.
|
||||||
|
|
||||||
|
|
|
@ -51,7 +51,7 @@
|
||||||
; e.g.: ((lambda () 0) 1 2 3)
|
; e.g.: ((lambda () 0) 1 2 3)
|
||||||
|
|
||||||
vehicles ; Controls how closures are compiled:
|
vehicles ; Controls how closures are compiled:
|
||||||
; 'vehicles:automatic,
|
; 'vehicles:automatic,
|
||||||
; 'vehicles:functions,
|
; 'vehicles:functions,
|
||||||
; 'vechicles:units, or
|
; 'vechicles:units, or
|
||||||
; 'vehicles:monolithic.
|
; 'vehicles:monolithic.
|
||||||
|
|
|
@ -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
|
uses CodeWarrior if it can be found and the compilation options
|
||||||
cannot be changed.
|
cannot be changed.
|
||||||
|
|
||||||
The unit/sig form defined by _compiler.ss_ (signature in
|
The unit form _dynext:compile@_ from _compile-unit.ss_ requires no
|
||||||
_compiles.ss_) requires no imports.
|
imports and exports _dynext:compile^_ from _compile-sig.ss_.
|
||||||
|
|
||||||
_link.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
|
CodeWarrior if it can be found and the linking options cannot be
|
||||||
changed.
|
changed.
|
||||||
|
|
||||||
The unit/sig form defined by _linkr.ss_ (signature in _links.ss_)
|
The unit form _dynext:link@_ from _link-unit.ss_ requires no
|
||||||
requires no imports.
|
imports and exports _dynext:link^_ from _link-sig.ss_.
|
||||||
|
|
||||||
_file.ss_
|
_file.ss_
|
||||||
---------
|
---------
|
||||||
|
@ -201,5 +201,5 @@ _file.ss_
|
||||||
> (extract-base-filename/ext s program) - same as
|
> (extract-base-filename/ext s program) - same as
|
||||||
extract-base-filename/ss, but for extension files.
|
extract-base-filename/ss, but for extension files.
|
||||||
|
|
||||||
The unit/sig defined by _filer.ss_ (signature in _files.ss_) requires
|
The unit form _dynext:file@_ from _file-unit.ss_ requires no
|
||||||
no imports.
|
imports and exports _dynext:file^_ from _file-sig.ss_.
|
||||||
|
|
|
@ -242,7 +242,7 @@ _Re-using errortrace stack tracing_
|
||||||
-----------------------------------
|
-----------------------------------
|
||||||
|
|
||||||
The errortrace collection also includes a _stacktrace.ss_ library. It
|
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^_.
|
_stacktrace-imports^_, and its export signature _stacktrace^_.
|
||||||
|
|
||||||
The export signature contains these names:
|
The export signature contains these names:
|
||||||
|
|
|
@ -9,15 +9,15 @@ possible to remap single click (instead of double click)?
|
||||||
|
|
||||||
(require (lib "cards.ss" "games" "cards")
|
(require (lib "cards.ss" "games" "cards")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "string-constant.ss" "string-constants")
|
(lib "string-constant.ss" "string-constants")
|
||||||
"../show-help.ss")
|
"../show-help.ss")
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -33,12 +33,12 @@
|
||||||
(require (lib "cards.ss" "games" "cards")
|
(require (lib "cards.ss" "games" "cards")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -7,11 +7,11 @@
|
||||||
(prefix gl- (lib "sgl.ss" "sgl"))
|
(prefix gl- (lib "sgl.ss" "sgl"))
|
||||||
(lib "gl.ss" "sgl")
|
(lib "gl.ss" "sgl")
|
||||||
(lib "array.ss" "srfi" "25")
|
(lib "array.ss" "srfi" "25")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "include-bitmap.ss" "mrlib")
|
(lib "include-bitmap.ss" "mrlib")
|
||||||
"honu-bitmaps.ss")
|
"honu-bitmaps.ss")
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define-struct image (width height rgba))
|
(define-struct image (width height rgba))
|
||||||
|
|
||||||
|
@ -65,10 +65,14 @@
|
||||||
(define-struct piece-info (x y color king?) (make-inspector))
|
(define-struct piece-info (x y color king?) (make-inspector))
|
||||||
(define-struct moves (list forced-jump?))
|
(define-struct moves (list forced-jump?))
|
||||||
|
|
||||||
(define checkers-view@
|
(define-signature model^
|
||||||
(unit
|
(move))
|
||||||
(import move)
|
(define-signature view^
|
||||||
(export add-space add-piece remove-piece move-piece set-turn show)
|
(add-space add-piece remove-piece move-piece set-turn show))
|
||||||
|
|
||||||
|
(define-unit view@
|
||||||
|
(import model^)
|
||||||
|
(export view^)
|
||||||
|
|
||||||
(define (get-space-draw-fn space)
|
(define (get-space-draw-fn space)
|
||||||
(let* ((list-id (get-square-dl (space-info-light? space)
|
(let* ((list-id (get-square-dl (space-info-light? space)
|
||||||
|
@ -298,12 +302,11 @@
|
||||||
(getter (if light? light-square dark-square))))
|
(getter (if light? light-square dark-square))))
|
||||||
|
|
||||||
(define (show)
|
(define (show)
|
||||||
(send f show #t))))
|
(send f show #t)))
|
||||||
|
|
||||||
(define checkers-model@
|
(define-unit model@
|
||||||
(unit
|
(import view^)
|
||||||
(import add-space add-piece remove-piece move-piece set-turn)
|
(export model^)
|
||||||
(export move)
|
|
||||||
|
|
||||||
(define turn 'red)
|
(define turn 'red)
|
||||||
(define board (make-array (shape 0 8 0 8) #f))
|
(define board (make-array (shape 0 8 0 8) #f))
|
||||||
|
@ -467,14 +470,16 @@
|
||||||
(set-turn turn (get-moves))))))))))
|
(set-turn turn (get-moves))))))))))
|
||||||
|
|
||||||
(set-turn turn (get-moves))
|
(set-turn turn (get-moves))
|
||||||
))
|
)
|
||||||
|
|
||||||
(define game-unit
|
(define-unit show@
|
||||||
(compound-unit
|
(import view^)
|
||||||
|
(export)
|
||||||
|
(show))
|
||||||
|
|
||||||
|
(define game@
|
||||||
|
(compound-unit/infer
|
||||||
(import)
|
(import)
|
||||||
(link
|
(export)
|
||||||
(VIEW (checkers-view@ (MODEL move)))
|
(link view@ model@ show@)))
|
||||||
(MODEL (checkers-model@ (VIEW add-space add-piece remove-piece move-piece set-turn)))
|
|
||||||
(SHOW ((unit (import show) (export) (show)) (VIEW show))))
|
|
||||||
(export)))
|
|
||||||
)
|
)
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
(require (lib "cards.ss" "games" "cards")
|
(require (lib "cards.ss" "games" "cards")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "etc.ss")
|
(lib "etc.ss")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "async-channel.ss")
|
(lib "async-channel.ss")
|
||||||
|
@ -34,10 +34,16 @@
|
||||||
(define SEL-WIDTH 32)
|
(define SEL-WIDTH 32)
|
||||||
(define SEL-HEIGHT 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:
|
;; This unit drives multiple Crazy 8 instances:
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
@ -62,19 +68,15 @@
|
||||||
(parameterize ([current-eventspace (make-eventspace)])
|
(parameterize ([current-eventspace (make-eventspace)])
|
||||||
(queue-callback
|
(queue-callback
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(invoke-unit configured-game-unit
|
(invoke-unit configured-game@ (import configuration^))))))))
|
||||||
opponents-count
|
|
||||||
init-hand-size
|
|
||||||
drag-mode?
|
|
||||||
new-game)))))))
|
|
||||||
|
|
||||||
;; Start the initial child game:
|
;; Start the initial child game:
|
||||||
(start-new-game opponents-count init-hand-size drag-mode?)))
|
(start-new-game opponents-count init-hand-size drag-mode?)))
|
||||||
|
|
||||||
;; This unit is for a particular Crazy 8 instance:
|
;; This unit is for a particular Crazy 8 instance:
|
||||||
(define configured-game-unit
|
(define configured-game@
|
||||||
(unit
|
(unit
|
||||||
(import opponents-count init-hand-size drag-mode? new-game)
|
(import configuration^)
|
||||||
(export)
|
(export)
|
||||||
|
|
||||||
;; Randomize
|
;; Randomize
|
||||||
|
|
|
@ -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
|
manual), the following fields of the collection's "info.ss" file are
|
||||||
used:
|
used:
|
||||||
|
|
||||||
* `game' [required] : used as a library name in the sub-collection to
|
* `game' [required] : used as a module name in the sub-collection to
|
||||||
load for the game; the library must export a `game-unit' unsigned
|
load for the game; the module must provide a `game@' unit (see
|
||||||
unit (see MzLib's `unit' form); the unit is invoked with no
|
MzLib's "unit.ss" form) with no particular exports; the unit is
|
||||||
imports to start the game.
|
invoked with no imports to start the game.
|
||||||
|
|
||||||
* `name' [defaults to the collection name] : used to label the
|
* `name' [defaults to the collection name] : used to label the
|
||||||
game-starting button in the game console.
|
game-starting button in the game console.
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
(module games mzscheme
|
(module games mzscheme
|
||||||
(require (lib "mred.ss" "mred")
|
(require (lib "mred.ss" "mred")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "getinfo.ss" "setup")
|
(lib "getinfo.ss" "setup")
|
||||||
(lib "bitmap-label.ss" "mrlib")
|
(lib "bitmap-label.ss" "mrlib")
|
||||||
|
@ -51,10 +51,10 @@
|
||||||
p)
|
p)
|
||||||
p
|
p
|
||||||
(lambda (b e)
|
(lambda (b e)
|
||||||
(let ([game-unit (dynamic-wind
|
(let ([game@ (dynamic-wind
|
||||||
begin-busy-cursor
|
begin-busy-cursor
|
||||||
(lambda () (dynamic-require (build-path dir file) 'game-unit))
|
(lambda () (dynamic-require (build-path dir file) 'game@))
|
||||||
end-busy-cursor)])
|
end-busy-cursor)])
|
||||||
(let ([c (make-custodian)])
|
(let ([c (make-custodian)])
|
||||||
(parameterize ([current-custodian c])
|
(parameterize ([current-custodian c])
|
||||||
(parameterize ([current-eventspace (make-eventspace)])
|
(parameterize ([current-eventspace (make-eventspace)])
|
||||||
|
@ -62,7 +62,7 @@
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(exit-handler (lambda (v)
|
(exit-handler (lambda (v)
|
||||||
(custodian-shutdown-all c)))
|
(custodian-shutdown-all c)))
|
||||||
(invoke-unit game-unit))))))))))))
|
(invoke-unit game@))))))))))))
|
||||||
|
|
||||||
(let ([game-mapping (sort game-mapping
|
(let ([game-mapping (sort game-mapping
|
||||||
(lambda (a b)
|
(lambda (a b)
|
||||||
|
|
|
@ -5,8 +5,8 @@
|
||||||
|
|
||||||
(module gcalc mzscheme
|
(module gcalc mzscheme
|
||||||
(require (lib "class.ss") (lib "mred.ss" "mred") (lib "etc.ss")
|
(require (lib "class.ss") (lib "mred.ss" "mred") (lib "etc.ss")
|
||||||
"../show-help.ss" (lib "unit200.ss"))
|
"../show-help.ss" (lib "unit.ss"))
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define customs '())
|
(define customs '())
|
||||||
(define (add-custom! name get set type desc)
|
(define (add-custom! name get set type desc)
|
||||||
|
@ -19,7 +19,7 @@
|
||||||
(begin (define var default)
|
(begin (define var default)
|
||||||
(add-custom! 'var (lambda () var) (lambda (v) (set! var v))
|
(add-custom! 'var (lambda () var) (lambda (v) (set! var v))
|
||||||
type description))]))
|
type description))]))
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit (import) (export)
|
(unit (import) (export)
|
||||||
|
|
||||||
;;;============================================================================
|
;;;============================================================================
|
||||||
|
|
|
@ -3,12 +3,12 @@
|
||||||
(require (lib "cards.ss" "games" "cards")
|
(require (lib "cards.ss" "games" "cards")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
(module gobblet mzscheme
|
(module gobblet mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
(lib "unit200.ss")
|
(only (lib "unit.ss") unit import export)
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
@ -10,9 +10,9 @@
|
||||||
"explore.ss"
|
"explore.ss"
|
||||||
"../show-help.ss")
|
"../show-help.ss")
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -3,12 +3,12 @@
|
||||||
(require (lib "cards.ss" "games" "cards")
|
(require (lib "cards.ss" "games" "cards")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
|
|
||||||
(module jewel mzscheme
|
(module jewel mzscheme
|
||||||
|
|
||||||
(require (lib "unit200.ss")
|
(require (lib "unit.ss")
|
||||||
(lib "string.ss")
|
(lib "string.ss")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
|
@ -17,10 +17,10 @@
|
||||||
"../show-help.ss"
|
"../show-help.ss"
|
||||||
)
|
)
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -3,14 +3,18 @@
|
||||||
"../show-help.ss"
|
"../show-help.ss"
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "class.ss")
|
(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
|
(unit
|
||||||
(import)
|
(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"))
|
(define frame (make-object frame% "Lights Out"))
|
||||||
|
|
||||||
|
|
|
@ -3,12 +3,12 @@
|
||||||
(require (lib "cards.ss" "games" "cards")
|
(require (lib "cards.ss" "games" "cards")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -1,23 +1,25 @@
|
||||||
|
|
||||||
;; An example implementation of the ever-popular Minesweeper game.
|
;; 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 ;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(module mines mzscheme
|
(module mines mzscheme
|
||||||
|
|
||||||
(require (lib "etc.ss") ; defines build-vector
|
(require (lib "etc.ss") ; defines build-vector
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "include-bitmap.ss" "mrlib"))
|
(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 tile-bm (include-bitmap "images/tile.png"))
|
||||||
(define lclick-bm (include-bitmap "images/lclick-tile.png"))
|
(define lclick-bm (include-bitmap "images/lclick-tile.png"))
|
||||||
(define rclick-bm (include-bitmap "images/rclick-tile.png"))
|
(define rclick-bm (include-bitmap "images/rclick-tile.png"))
|
||||||
|
@ -27,42 +29,37 @@
|
||||||
(define explode-bm (include-bitmap "images/explode.png"))
|
(define explode-bm (include-bitmap "images/explode.png"))
|
||||||
(define flag-bm (include-bitmap "images/flag.png"))
|
(define flag-bm (include-bitmap "images/flag.png"))
|
||||||
|
|
||||||
;; The game is implemented in a unit so it can be started multiple times
|
(define DIGIT-COLOR-NAMES
|
||||||
(define game-unit
|
;; 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 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
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(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 ;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;; Class for a tile object
|
;; Class for a tile object
|
||||||
|
|
|
@ -7,12 +7,12 @@
|
||||||
"../show-help.ss"
|
"../show-help.ss"
|
||||||
(lib "framework.ss" "framework")
|
(lib "framework.ss" "framework")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "pretty.ss")
|
(lib "pretty.ss")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "mred.ss" "mred"))
|
(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))
|
(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%)))
|
(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 (send f get-canvas) set-grid state)
|
||||||
(send f show #t))]))
|
(send f show #t))]))
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -1,11 +1,13 @@
|
||||||
|
|
||||||
(module parcheesi mzscheme
|
(module parcheesi mzscheme
|
||||||
(require (lib "unit200.ss")
|
(require (lib "unit.ss")
|
||||||
(lib "class.ss"))
|
(lib "class.ss")
|
||||||
|
"admin-gui.ss")
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit (import)
|
(unit (import)
|
||||||
(export)
|
(export)
|
||||||
(new (dynamic-require '(lib "admin-gui.ss" "games" "parcheesi") 'gui-game%)))))
|
(new gui-game%))))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -4,13 +4,13 @@
|
||||||
"board-size.ss"
|
"board-size.ss"
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "class100.ss")
|
(lib "class100.ss")
|
||||||
(lib "unit200.ss")
|
(all-except (lib "unit.ss") rename) ; rename collides with class100
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(prefix robot: "robot.ss"))
|
(prefix robot: "robot.ss"))
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -1,14 +1,14 @@
|
||||||
(module same mzscheme
|
(module same mzscheme
|
||||||
(require (lib "etc.ss")
|
(require (lib "etc.ss")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
"../show-help.ss")
|
"../show-help.ss")
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -2,12 +2,12 @@
|
||||||
(module slidey mzscheme
|
(module slidey mzscheme
|
||||||
(require (lib "etc.ss")
|
(require (lib "etc.ss")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "mred.ss" "mred"))
|
(lib "mred.ss" "mred"))
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
"../show-help.ss")
|
"../show-help.ss")
|
||||||
|
|
||||||
(define (list-first-n l n)
|
(define (list-first-n l n)
|
||||||
|
@ -16,9 +16,9 @@
|
||||||
(define (vector-copy v)
|
(define (vector-copy v)
|
||||||
(list->vector (vector->list v)))
|
(list->vector (vector->list v)))
|
||||||
|
|
||||||
(provide game-unit)
|
(provide game@)
|
||||||
|
|
||||||
(define game-unit
|
(define game@
|
||||||
(unit
|
(unit
|
||||||
(import)
|
(import)
|
||||||
(export)
|
(export)
|
||||||
|
|
|
@ -11,7 +11,7 @@
|
||||||
(lib "string-constant.ss" "string-constants")
|
(lib "string-constant.ss" "string-constants")
|
||||||
(lib "external.ss" "browser")
|
(lib "external.ss" "browser")
|
||||||
|
|
||||||
(prefix browser: (lib "browser-sig.ss" "browser"))
|
(lib "browser-sig.ss" "browser")
|
||||||
(lib "url-sig.ss" "net")
|
(lib "url-sig.ss" "net")
|
||||||
(lib "url-structs.ss" "net")
|
(lib "url-structs.ss" "net")
|
||||||
(lib "uri-codec.ss" "net")
|
(lib "uri-codec.ss" "net")
|
||||||
|
@ -26,7 +26,7 @@
|
||||||
|
|
||||||
"internal-hp.ss")
|
"internal-hp.ss")
|
||||||
|
|
||||||
(import browser:hyper^ browser:html-export^ browser:bullet-export^ url^)
|
(import browser^ url^)
|
||||||
(export gui^)
|
(export gui^)
|
||||||
|
|
||||||
(define help-desk-frame<%>
|
(define help-desk-frame<%>
|
||||||
|
|
|
@ -1,12 +1,9 @@
|
||||||
|
|
||||||
_Hierarchical List Control_
|
_Hierarchical List Control_
|
||||||
|
|
||||||
hierlists.ss defines hierlist^
|
hierlist.ss provides the classes and interfaces described below.
|
||||||
hierlistr.ss returns a unit/sig, imports mred^ and
|
hierlist-sig.ss provides hierlist^, which includes the same classes and interfaces.
|
||||||
mzlib:function^ and exports hierlist^
|
hierlist-unit.ss provide a unit that imports mred^ and exports hierlist^.
|
||||||
hierlist.ss invoke-opens hierlistr.ss
|
|
||||||
|
|
||||||
_hierlist_ defines three classes:
|
|
||||||
|
|
||||||
--------------------------------------------------
|
--------------------------------------------------
|
||||||
|
|
||||||
|
|
|
@ -8,7 +8,7 @@ languages for other modules (i.e., as the initial import):
|
||||||
|
|
||||||
* _plt-pretty-big-text.ss_ - provides MzScheme plus the
|
* _plt-pretty-big-text.ss_ - provides MzScheme plus the
|
||||||
following MzLib libraries: etc.ss, file.ss, list.ss,
|
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
|
pretty.ss, string.ss, thread.ss, math.ss, match.ss, and
|
||||||
shared.ss. It also provides the posn, color, and image
|
shared.ss. It also provides the posn, color, and image
|
||||||
functions of Beginning Student.
|
functions of Beginning Student.
|
||||||
|
|
|
@ -4,8 +4,7 @@
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unit200.ss")
|
(lib "unit.ss")
|
||||||
(lib "unitsig.ss")
|
|
||||||
(lib "include.ss")
|
(lib "include.ss")
|
||||||
(lib "defmacro.ss")
|
(lib "defmacro.ss")
|
||||||
(lib "pretty.ss")
|
(lib "pretty.ss")
|
||||||
|
@ -21,8 +20,7 @@
|
||||||
(all-from (lib "file.ss"))
|
(all-from (lib "file.ss"))
|
||||||
(all-from (lib "list.ss"))
|
(all-from (lib "list.ss"))
|
||||||
(all-from (lib "class.ss"))
|
(all-from (lib "class.ss"))
|
||||||
(all-from (lib "unit200.ss"))
|
(all-from (lib "unit.ss"))
|
||||||
(all-from (lib "unitsig.ss"))
|
|
||||||
(all-from (lib "include.ss"))
|
(all-from (lib "include.ss"))
|
||||||
(all-from (lib "defmacro.ss"))
|
(all-from (lib "defmacro.ss"))
|
||||||
(all-from (lib "pretty.ss"))
|
(all-from (lib "pretty.ss"))
|
||||||
|
|
|
@ -1,8 +1,12 @@
|
||||||
|
|
||||||
The _launcherr.ss_ library in the "launcher" collection imports
|
The _launcher.ss_ library in the "launcher" collection provides the
|
||||||
mzlib:file^, dynext:compile^, and dynext:link^, and exports the
|
following procedures.
|
||||||
following procedures for creating MzScheme and MrEd launcher
|
|
||||||
executables.
|
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 ========================================
|
===== Launcher creation ========================================
|
||||||
|
|
||||||
|
|
|
@ -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
|
the target(s), and the `orig-exn' field is the original
|
||||||
exception.
|
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.ss also provides the following parameters:
|
||||||
|
|
||||||
> (make-print-checking [on?]) - If #f, make only prints when
|
> (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
|
> (make-print-reasons [on?]) If #t, make prints the reason
|
||||||
for each dependency that fires. Default: #t.
|
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_
|
_collection.ss_
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
|
|
|
@ -8,8 +8,6 @@
|
||||||
"match-error.ss"
|
"match-error.ss"
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(require (only (lib "1.ss" "srfi") zip unzip2))
|
|
||||||
|
|
||||||
(require-for-template mzscheme)
|
(require-for-template mzscheme)
|
||||||
|
|
||||||
;; define a syntax-transformer in terms of a two-argument function
|
;; 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.
|
;; 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
|
;; this function returns 2 lists of the same length if the inputs were the same length
|
||||||
(define (handle-acc/mut-lists accs muts)
|
(define (handle-acc/mut-lists accs muts)
|
||||||
(let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (zip accs muts))]
|
(let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (map list accs muts))]
|
||||||
[(accs muts) (unzip2 filtered-lists)])
|
[(accs muts) (values (map car filtered-lists)
|
||||||
|
(map cadr filtered-lists))])
|
||||||
(values (reverse accs)
|
(values (reverse accs)
|
||||||
(reverse muts))))
|
(reverse muts))))
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
(module render-test-list-impl mzscheme
|
(module render-test-list-impl mzscheme
|
||||||
|
|
||||||
(require (lib "stx.ss" "syntax"))
|
(require (lib "stx.ss" "syntax"))
|
||||||
(require (rename (lib "1.ss" "srfi") map-append append-map))
|
|
||||||
|
|
||||||
(require "match-error.ss"
|
(require "match-error.ss"
|
||||||
"match-helper.ss"
|
"match-helper.ss"
|
||||||
|
@ -226,8 +225,10 @@
|
||||||
((app op pat)
|
((app op pat)
|
||||||
(render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx))
|
(render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx))
|
||||||
|
|
||||||
[(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx))
|
[(and . pats) (apply
|
||||||
(syntax->list #'pats))]
|
append
|
||||||
|
(map (lambda (pat) (render-test-list pat ae cert stx))
|
||||||
|
(syntax->list #'pats)))]
|
||||||
|
|
||||||
((or . pats)
|
((or . pats)
|
||||||
(list (make-act
|
(list (make-act
|
||||||
|
@ -372,24 +373,26 @@
|
||||||
,(map syntax-object->datum parental-chain)
|
,(map syntax-object->datum parental-chain)
|
||||||
,ae-datum)
|
,ae-datum)
|
||||||
ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp)))
|
ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp)))
|
||||||
(map-append
|
(apply
|
||||||
(lambda (cur-pat cur-mutator cur-accessor)
|
append
|
||||||
(syntax-case cur-pat (set! get!)
|
(map
|
||||||
[(set! . rest)
|
(lambda (cur-pat cur-mutator cur-accessor)
|
||||||
(unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields"))
|
(syntax-case cur-pat (set! get!)
|
||||||
(set/get-matcher 'set! ae p #'rest
|
[(set! . rest)
|
||||||
#`(lambda (y)
|
(unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields"))
|
||||||
(#,cur-mutator #,ae y)))]
|
(set/get-matcher 'set! ae p #'rest
|
||||||
[(get! . rest)
|
#`(lambda (y)
|
||||||
(set/get-matcher 'get! ae p #'rest
|
(#,cur-mutator #,ae y)))]
|
||||||
#`(lambda ()
|
[(get! . rest)
|
||||||
(#,cur-accessor #,ae)))]
|
(set/get-matcher 'get! ae p #'rest
|
||||||
[_ (render-test-list
|
#`(lambda ()
|
||||||
cur-pat
|
(#,cur-accessor #,ae)))]
|
||||||
(quasisyntax/loc cur-pat (#,cur-accessor #,ae))
|
[_ (render-test-list
|
||||||
cert
|
cur-pat
|
||||||
stx)]))
|
(quasisyntax/loc cur-pat (#,cur-accessor #,ae))
|
||||||
field-pats mutators accessors))))
|
cert
|
||||||
|
stx)]))
|
||||||
|
field-pats mutators accessors)))))
|
||||||
|
|
||||||
;; syntax checking
|
;; syntax checking
|
||||||
((struct ident ...)
|
((struct ident ...)
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
(module simplify-patterns mzscheme
|
(module simplify-patterns mzscheme
|
||||||
|
|
||||||
(require (lib "stx.ss" "syntax"))
|
(require (lib "stx.ss" "syntax"))
|
||||||
(require (rename (lib "1.ss" "srfi") map-append append-map))
|
|
||||||
|
|
||||||
(require "match-error.ss"
|
(require "match-error.ss"
|
||||||
"match-helper.ss"
|
"match-helper.ss"
|
||||||
|
@ -14,8 +13,7 @@
|
||||||
"render-helpers.ss"
|
"render-helpers.ss"
|
||||||
"observe-step.ss")
|
"observe-step.ss")
|
||||||
|
|
||||||
(require "render-sigs.ss"
|
(require "render-sigs.ss")
|
||||||
(lib "unitsig.ss"))
|
|
||||||
|
|
||||||
(require-for-syntax "match-helper.ss"
|
(require-for-syntax "match-helper.ss"
|
||||||
"match-expander-struct.ss"
|
"match-expander-struct.ss"
|
||||||
|
|
|
@ -206,12 +206,12 @@
|
||||||
((((vid ...) . vbody) ...) all-val-defs)
|
((((vid ...) . vbody) ...) all-val-defs)
|
||||||
((((sid ...) . sbody) ...) all-stx-defs))
|
((((sid ...) . sbody) ...) all-stx-defs))
|
||||||
#`(begin
|
#`(begin
|
||||||
(define x (gensym))
|
(define signature-tag (gensym))
|
||||||
(define-syntax #,sigid
|
(define-syntax #,sigid
|
||||||
(make-set!-transformer
|
(make-set!-transformer
|
||||||
(make-signature
|
(make-signature
|
||||||
(make-siginfo (list #'#,sigid #'super-name ...)
|
(make-siginfo (list #'#,sigid #'super-name ...)
|
||||||
(list ((syntax-local-certifier) (quote-syntax x))
|
(list ((syntax-local-certifier) (quote-syntax signature-tag))
|
||||||
#'super-rtime
|
#'super-rtime
|
||||||
...))
|
...))
|
||||||
(list (quote-syntax var) ...)
|
(list (quote-syntax var) ...)
|
||||||
|
@ -294,12 +294,26 @@
|
||||||
(define-for-syntax (signature->identifiers sigids)
|
(define-for-syntax (signature->identifiers sigids)
|
||||||
(define provide-tagged-sigs (map process-tagged-import sigids))
|
(define provide-tagged-sigs (map process-tagged-import sigids))
|
||||||
(define provide-sigs (map caddr provide-tagged-sigs))
|
(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)
|
(define-syntax/err-param (provide-signature-elements stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
((_ . p)
|
((_ . 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)))
|
(dup (check-duplicate-identifier names)))
|
||||||
(when dup
|
(when dup
|
||||||
(raise-stx-err (format "duplicate binding for ~e" (syntax-e dup))))
|
(raise-stx-err (format "duplicate binding for ~e" (syntax-e dup))))
|
||||||
|
|
|
@ -17,8 +17,8 @@ _URL_ posting, _web clients_, _WWW_
|
||||||
|
|
||||||
To load directly: (require (lib "url.ss" "net"))
|
To load directly: (require (lib "url.ss" "net"))
|
||||||
Module files: _url.ss_ - provides the procedures documented below
|
Module files: _url.ss_ - provides the procedures documented below
|
||||||
_url-unit.ss_ - provides unit net:url@
|
_url-unit.ss_ - provides unit url@
|
||||||
_url-sig.ss_ - provides signature net:url^
|
_url-sig.ss_ - provides signature url^
|
||||||
_url-struct.ss_ - provides the url and path/param structs
|
_url-struct.ss_ - provides the url and path/param structs
|
||||||
|
|
||||||
|
|
||||||
|
@ -234,10 +234,10 @@ EXAMPLE --------------------------------------------------------------
|
||||||
|
|
||||||
UNITS ----------------------------------------------------------------
|
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
|
contains the names documented above. the _url-unit.ss_ module exports
|
||||||
_url@_, a unit that imports net:tcp^ (see "tcp-sig.ss", below) and
|
_url@_, a unit that imports tcp^ (see "tcp-sig.ss", below) and
|
||||||
exports the names in net:url^.
|
exports the names in url^.
|
||||||
|
|
||||||
==========================================================================
|
==========================================================================
|
||||||
_URL viewing_
|
_URL viewing_
|
||||||
|
@ -287,8 +287,8 @@ _CGI_ backends, _WWW_
|
||||||
|
|
||||||
To load directly: (require (lib "cgi.ss" "net"))
|
To load directly: (require (lib "cgi.ss" "net"))
|
||||||
Module files: _cgi.ss_ - provides the procedures documented below
|
Module files: _cgi.ss_ - provides the procedures documented below
|
||||||
_cgi-unit.ss_ - provides unit net:cgi@
|
_cgi-unit.ss_ - provides unit cgi@
|
||||||
_cgi-sig.ss_ - provides signature net:cgi^
|
_cgi-sig.ss_ - provides signature cgi^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -416,8 +416,8 @@ _sending mail_, _sendmail_
|
||||||
|
|
||||||
To load directly: (require (lib "sendmail.ss" "net"))
|
To load directly: (require (lib "sendmail.ss" "net"))
|
||||||
Module files: _sendmail.ss_ - provides the procedures documented below
|
Module files: _sendmail.ss_ - provides the procedures documented below
|
||||||
_sendmail-unit.ss_ - provides unit net:sendmail@
|
_sendmail-unit.ss_ - provides unit sendmail@
|
||||||
_sendmail-sig.ss_ - provides signature net:sendmail^
|
_sendmail-sig.ss_ - provides signature sendmail^
|
||||||
|
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
@ -472,8 +472,8 @@ _sending mail_, _SMTP_
|
||||||
|
|
||||||
To load directly: (require (lib "smtp.ss" "net"))
|
To load directly: (require (lib "smtp.ss" "net"))
|
||||||
Module files: _smtp.ss_ - provides the procedures documented below
|
Module files: _smtp.ss_ - provides the procedures documented below
|
||||||
_smtp-unit.ss_ - provides unit net:smtp@
|
_smtp-unit.ss_ - provides unit smtp@
|
||||||
_smtp-sig.ss_ - provides signature net:smtp^
|
_smtp-sig.ss_ - provides signature smtp^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -548,8 +548,8 @@ _NNTP_, _newsgroups_
|
||||||
|
|
||||||
To load directly: (require (lib "nntp.ss" "net"))
|
To load directly: (require (lib "nntp.ss" "net"))
|
||||||
Module files: _nntp.ss_ - provides the procedures documented below
|
Module files: _nntp.ss_ - provides the procedures documented below
|
||||||
_nntp-unit.ss_ - provides unit net:nntp@
|
_nntp-unit.ss_ - provides unit nntp@
|
||||||
_nntp-sig.ss_ - provides signature net:nntp^
|
_nntp-sig.ss_ - provides signature nntp^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -695,8 +695,8 @@ _POP-3_, _reading mail_
|
||||||
|
|
||||||
To load directly: (require (lib "pop3.ss" "net"))
|
To load directly: (require (lib "pop3.ss" "net"))
|
||||||
Module files: _pop3.ss_ - provides the procedures documented below
|
Module files: _pop3.ss_ - provides the procedures documented below
|
||||||
_pop3-unit.ss_ - provides unit net:pop3@
|
_pop3-unit.ss_ - provides unit pop3@
|
||||||
_pop3-sig.ss_ - provides signature net:pop3^
|
_pop3-sig.ss_ - provides signature pop3^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -874,8 +874,8 @@ _IMAP_, _reading mail_
|
||||||
|
|
||||||
To load directly: (require (lib "imap.ss" "net"))
|
To load directly: (require (lib "imap.ss" "net"))
|
||||||
Module files: _imap.ss_ - provides the procedures documented below
|
Module files: _imap.ss_ - provides the procedures documented below
|
||||||
_imap-unit.ss_ - provides unit net:imap@
|
_imap-unit.ss_ - provides unit imap@
|
||||||
_imap-sig.ss_ - provides signature net:imap^
|
_imap-sig.ss_ - provides signature imap^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -1249,8 +1249,8 @@ _mime headers_, _mail headers_, _http headers_
|
||||||
|
|
||||||
To load directly: (require (lib "head.ss" "net"))
|
To load directly: (require (lib "head.ss" "net"))
|
||||||
Module files: _head.ss_ - provides the procedures documented below
|
Module files: _head.ss_ - provides the procedures documented below
|
||||||
_head-unit.ss_ - provides unit net:head@
|
_head-unit.ss_ - provides unit head@
|
||||||
_head-sig.ss_ - provides signature net:head^
|
_head-sig.ss_ - provides signature head^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -1400,8 +1400,8 @@ _DNS_, _domain name service_
|
||||||
|
|
||||||
To load directly: (require (lib "dns.ss" "net"))
|
To load directly: (require (lib "dns.ss" "net"))
|
||||||
Module files: _dns.ss_ - provides the procedures documented below
|
Module files: _dns.ss_ - provides the procedures documented below
|
||||||
_dns-unit.ss_ - provides unit net:dns@
|
_dns-unit.ss_ - provides unit dns@
|
||||||
_dns-sig.ss_ - provides signature net:dns^
|
_dns-sig.ss_ - provides signature dns^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -1446,10 +1446,10 @@ _MIME support__
|
||||||
|
|
||||||
To load directly: (require (lib "mime.ss" "net"))
|
To load directly: (require (lib "mime.ss" "net"))
|
||||||
Module files: _mime.ss_ - provides the procedures documented below
|
Module files: _mime.ss_ - provides the procedures documented below
|
||||||
_mime-unit.ss_ - provides unit net:mime@
|
_mime-unit.ss_ - provides unit mime@
|
||||||
imports net:base64^ from "base64-sig.ss"
|
imports base64^ from "base64-sig.ss"
|
||||||
and net:qp^ from "qp-sig.ss"
|
and qp^ from "qp-sig.ss"
|
||||||
_mime-sig.ss_ - provides signature net:mime^
|
_mime-sig.ss_ - provides signature mime^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -1758,8 +1758,8 @@ _Base 64 Encoding_, _base64_
|
||||||
|
|
||||||
To load directly: (require (lib "base64.ss" "net"))
|
To load directly: (require (lib "base64.ss" "net"))
|
||||||
Module files: _base64.ss_ - provides the procedures documented below
|
Module files: _base64.ss_ - provides the procedures documented below
|
||||||
_base64-unit.ss_ - provides unit net:base64@
|
_base64-unit.ss_ - provides unit base64@
|
||||||
_base64-sig.ss_ - provides signature net:base64^
|
_base64-sig.ss_ - provides signature base64^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -1800,8 +1800,8 @@ _Quoted Printable Encoding_, _qp__
|
||||||
|
|
||||||
To load directly: (require (lib "qp.ss" "net"))
|
To load directly: (require (lib "qp.ss" "net"))
|
||||||
Module files: _qp.ss_ - provides the procedures documented below
|
Module files: _qp.ss_ - provides the procedures documented below
|
||||||
_qp-unit.ss_ - provides unit net:qp@
|
_qp-unit.ss_ - provides unit qp@
|
||||||
_qp-sig.ss_ - provides signature net:qp^
|
_qp-sig.ss_ - provides signature qp^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -1867,8 +1867,8 @@ _FTP client_
|
||||||
|
|
||||||
To load directly: (require (lib "ftp.ss" "net"))
|
To load directly: (require (lib "ftp.ss" "net"))
|
||||||
Module files: _ftp.ss_ - provides the procedures documented below
|
Module files: _ftp.ss_ - provides the procedures documented below
|
||||||
_ftp-unit.ss_ - provides unit net:ftp@
|
_ftp-unit.ss_ - provides unit ftp@
|
||||||
_ftp-sig.ss_ - provides signature net:ftp^
|
_ftp-sig.ss_ - provides signature ftp^
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -1933,12 +1933,12 @@ _TCP redirect_
|
||||||
==========================================================================
|
==========================================================================
|
||||||
|
|
||||||
The "tcp-redirect.ss" library provides an function to generate a unit
|
The "tcp-redirect.ss" library provides an function to generate a unit
|
||||||
with the signature net:tcp^ that redirects certain port numbers to
|
with the signature tcp^ that redirects certain port numbers to
|
||||||
intra-process listeners that do not actually use TCP. The net:tcp^
|
intra-process listeners that do not actually use TCP. The tcp^
|
||||||
signature is imported, for example, by the url@ unit of "url-unit.ss".
|
signature is imported, for example, by the url@ unit of "url-unit.ss".
|
||||||
|
|
||||||
Module file: _tcp-redirect.ss_ - provides the `tcp-redirect-function
|
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:
|
following:
|
||||||
tcp-abandon-port
|
tcp-abandon-port
|
||||||
tcp-accept
|
tcp-accept
|
||||||
|
@ -1950,7 +1950,7 @@ Module file: _tcp-redirect.ss_ - provides the `tcp-redirect-function
|
||||||
tcp-listen
|
tcp-listen
|
||||||
tcp-listener?
|
tcp-listener?
|
||||||
_tcp-unit.ss_ - defines _tcp@_ which implements
|
_tcp-unit.ss_ - defines _tcp@_ which implements
|
||||||
net:tcp^ using the MzScheme functions of
|
tcp^ using the MzScheme functions of
|
||||||
the same name
|
the same name
|
||||||
ssl-tcp-unit.ss - see below
|
ssl-tcp-unit.ss - see below
|
||||||
|
|
||||||
|
@ -1958,7 +1958,7 @@ PROCEDURES -----------------------------------------------------------
|
||||||
|
|
||||||
> (tcp-redirect port-number-list)
|
> (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
|
port numbers not listed in `port-number-list', the unit's
|
||||||
implementations are the MzScheme implementations.
|
implementations are the MzScheme implementations.
|
||||||
|
|
||||||
|
@ -1972,7 +1972,7 @@ _SSL redirect__
|
||||||
==========================================================================
|
==========================================================================
|
||||||
|
|
||||||
The _ssl-tcp-unit.ss_ library provides `make-ssl-tcp@', which returns
|
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 -----------------------------------------------------------
|
PROCEDURES -----------------------------------------------------------
|
||||||
|
|
||||||
|
@ -1981,7 +1981,7 @@ PROCEDURES -----------------------------------------------------------
|
||||||
server-suggest-auth-file
|
server-suggest-auth-file
|
||||||
client-cert-file client-key-file client-root-cert-files)
|
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
|
(lib "mzssl.ss" "openssl"). The arguments to `make-ssl-tcp@' control
|
||||||
the certificates and keys uses by server and client connections:
|
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"))
|
To load directly: (require (lib "cookie.ss" "net"))
|
||||||
Module files: _cookie.ss_ - provides the procedures documented below
|
Module files: _cookie.ss_ - provides the procedures documented below
|
||||||
_cookie-unit.ss_ - provides unit net:cookie@
|
_cookie-unit.ss_ - provides unit cookie@
|
||||||
_cookie-sig.ss_ - provides signature net:cookie^
|
_cookie-sig.ss_ - provides signature cookie^
|
||||||
|
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
@ -2147,8 +2147,8 @@ _URL encoding_, _URL decoding_, _application/x-www-form-urlencoded_
|
||||||
|
|
||||||
To load directly: (require (lib "uri-codec.ss" "net"))
|
To load directly: (require (lib "uri-codec.ss" "net"))
|
||||||
Module files: _uri-codec.ss_ - provides the procedures documented below
|
Module files: _uri-codec.ss_ - provides the procedures documented below
|
||||||
_uri-codec-unit.ss_ - provides unit net:uri-codec@
|
_uri-codec-unit.ss_ - provides unit uri-codec@
|
||||||
_uri-codec-sig.ss_ - provides signature net:uri-codec^
|
_uri-codec-sig.ss_ - provides signature uri-codec^
|
||||||
|
|
||||||
|
|
||||||
ABSTRACT -------------------------------------------------------------
|
ABSTRACT -------------------------------------------------------------
|
||||||
|
|
|
@ -3,8 +3,7 @@
|
||||||
(require "planet-shared.ss"
|
(require "planet-shared.ss"
|
||||||
"../config.ss"
|
"../config.ss"
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "match.ss")
|
(lib "match.ss"))
|
||||||
(prefix srfi1: (lib "1.ss" "srfi")))
|
|
||||||
|
|
||||||
(provide get/linkage
|
(provide get/linkage
|
||||||
get-linkage
|
get-linkage
|
||||||
|
@ -173,9 +172,4 @@
|
||||||
; desuffix : path -> path
|
; desuffix : path -> path
|
||||||
; removes the suffix from the given file
|
; removes the suffix from the given file
|
||||||
(define (desuffix file)
|
(define (desuffix file)
|
||||||
(let ((the-extension (filename-extension file))
|
(path-replace-suffix 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))))
|
|
||||||
|
|
|
@ -262,12 +262,12 @@ namespace.
|
||||||
Link the options and setup units so that your option-setting code is
|
Link the options and setup units so that your option-setting code is
|
||||||
initialized between them, e.g.:
|
initialized between them, e.g.:
|
||||||
|
|
||||||
(compound-unit/sig
|
(compound-unit
|
||||||
...
|
...
|
||||||
(link ...
|
(link ...
|
||||||
[OPTIONS : setup-option^ (setup:option@)]
|
[(OPTIONS : setup-option^) setup:option@]
|
||||||
[MY-CODE : () (my-init-options@ OPTIONS)]
|
[() my-init-options@ OPTIONS]
|
||||||
[SETUP : () (setup@ OPTIONS ...)])
|
[() setup@ OPTIONS ...])
|
||||||
...)
|
...)
|
||||||
|
|
||||||
|
|
||||||
|
@ -499,16 +499,17 @@ The raw format is
|
||||||
The procedure is extracted from the archive using MzScheme's `read'
|
The procedure is extracted from the archive using MzScheme's `read'
|
||||||
and `eval' procedures (in a fresh namespace).
|
and `eval' procedures (in a fresh namespace).
|
||||||
|
|
||||||
* An unsigned unit that drives the unpacking process. The unit
|
* An old-style, unsigned unit using `(lib "unit200.ss")' that drives
|
||||||
accepts two imports: a path string for the parent of the main
|
the unpacking process. The unit accepts two imports: a path string
|
||||||
"collects" directory and an `unmztar' procedure. The remainder of
|
for the parent of the main "collects" directory and an `unmztar'
|
||||||
the unpacking process consists of invoking this unit. It is
|
procedure. The remainder of the unpacking process consists of
|
||||||
expected that the unit will call `unmztar' procedure to unpack
|
invoking this unit. It is expected that the unit will call
|
||||||
directories and files that are defined in the input archive after
|
`unmztar' procedure to unpack directories and files that are
|
||||||
this unit. The result of invoking the unit must be a list of
|
defined in the input archive after this unit. The result of
|
||||||
collection paths (where each collection path is a list of strings);
|
invoking the unit must be a list of collection paths (where each
|
||||||
once the archive is unpacked, Setup PLT will compile and setup the
|
collection path is a list of strings); once the archive is
|
||||||
specified collections.
|
unpacked, Setup PLT will compile and setup the specified
|
||||||
|
collections.
|
||||||
|
|
||||||
The `unmztar' procedure takes one argument: a filter
|
The `unmztar' procedure takes one argument: a filter
|
||||||
procedure. The filter procedure is called for each directory and
|
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]
|
[#:file-filter filter-proc]
|
||||||
[#:encode? encode?]
|
[#:encode? encode?]
|
||||||
[#:file-mode file-mode-sym]
|
[#:file-mode file-mode-sym]
|
||||||
[#:unpack-unit unit-expr-or-#f]
|
[#:unpack-unit unit200-expr-or-#f]
|
||||||
[#:collections collection-list]
|
[#:collections collection-list]
|
||||||
[#:plt-relative? plt-relative?]
|
[#:plt-relative? plt-relative?]
|
||||||
[#:at-plt-home? at-plt-home?]
|
[#:at-plt-home? at-plt-home?]
|
||||||
|
@ -648,8 +649,8 @@ general functions to help make .plt archives:
|
||||||
is 'file.
|
is 'file.
|
||||||
|
|
||||||
The `unpack-unit' argument is usually #f. Otherwise, it must be an
|
The `unpack-unit' argument is usually #f. Otherwise, it must be an
|
||||||
S-expression for a unsigned unit that performs the work of
|
S-expression for a `(lib "unit200.ss")'-style unit that performs the
|
||||||
unpacking; see the above section on .plt internals for more
|
work of unpacking; see the above section on .plt internals for more
|
||||||
information about the unit. If `unpack-unit' is #f, an appropriate
|
information about the unit. If `unpack-unit' is #f, an appropriate
|
||||||
unpacking unit is generated.
|
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.
|
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^
|
The _plt-installer-sig.ss_ library defines the setup:plt-installer^
|
||||||
signature, which has two names: run-installer and on-installer-run.
|
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^.
|
||||||
|
|
|
@ -14,7 +14,7 @@
|
||||||
real? number? boolean?
|
real? number? boolean?
|
||||||
procedure? symbol?
|
procedure? symbol?
|
||||||
string? bytes?
|
string? bytes?
|
||||||
vector?
|
vector? box?
|
||||||
eof-object?))
|
eof-object?))
|
||||||
(let ([s (with-handlers ([exn? exn-message])
|
(let ([s (with-handlers ([exn? exn-message])
|
||||||
(proc 'bad))]
|
(proc 'bad))]
|
||||||
|
@ -101,6 +101,8 @@
|
||||||
(un #f 'symbol? #f)
|
(un #f 'symbol? #f)
|
||||||
(un #t 'vector? (vector 1 2 3))
|
(un #t 'vector? (vector 1 2 3))
|
||||||
(un #f 'vector? #f)
|
(un #f 'vector? #f)
|
||||||
|
(un #t 'box? (box 10))
|
||||||
|
(un #f 'box? #f)
|
||||||
(un #t 'string? "apple")
|
(un #t 'string? "apple")
|
||||||
(un #f 'string? #"apple")
|
(un #f 'string? #"apple")
|
||||||
(un #f 'bytes? "apple")
|
(un #f 'bytes? "apple")
|
||||||
|
|
1652
collects/tests/mzscheme/prompt-tests.ss
Normal file
1652
collects/tests/mzscheme/prompt-tests.ss
Normal file
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -1,6 +1,8 @@
|
||||||
|
|
||||||
(load-relative "loadtest.ss")
|
(load-relative "loadtest.ss")
|
||||||
|
|
||||||
|
;; ----------------------------------------
|
||||||
|
|
||||||
(test 0 'with-handlers (with-handlers () 0))
|
(test 0 'with-handlers (with-handlers () 0))
|
||||||
(test 1 'with-handlers (with-handlers ([void void]) 1))
|
(test 1 'with-handlers (with-handlers ([void void]) 1))
|
||||||
(test 2 'with-handlers (with-handlers ([void void]) 1 2))
|
(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))))
|
(let ([x (cons 1 2)]) (let ([f (lambda (x) x)]) (f (lambda (y) x))))
|
||||||
10)
|
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)
|
(report-errs)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user