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

lazy, force, delay in scheme/promise and scheme; clean up mzscheme some, and clean up the docs some

Browse Source 
svn: r8053
This commit is contained in:
Matthew Flatt 2007-12-18 21:37:23 +00:00
parent 49f198dad7
commit 415cd0bf15
36 changed files with 503 additions and 287 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/compiler/embed-unit.ss
View File

@ -4,6 +4,7 @@
scheme/path
scheme/file
scheme/port
scheme/promise
syntax/moddep
xml/plist
setup/dirs

3
collects/compiler/private/driver.ss
View File

@ -631,7 +631,8 @@
(s:expand-top-level-expressions!
input-directory
(lambda ()
(read-syntax (path->complete-path input-path) input-port))
(parameterize ([read-accept-reader #t])
(read-syntax (path->complete-path input-path) input-port)))
(compiler:option:verbose)))))))])
(verbose-time read-thunk)
(close-input-port input-port)

1
collects/framework/private/icon.ss
View File

@ -1,5 +1,6 @@
#lang scheme/unit
(require (for-syntax scheme/base)
scheme/promise
(lib "class.ss")
(lib "include-bitmap.ss" "mrlib")
"bday.ss"

1
collects/lang/htdp-advanced.ss
View File

@ -7,6 +7,7 @@
mzlib/list
mzlib/pretty
syntax/docprovide
scheme/promise
"posn.ss")
;; syntax:

8
collects/mzlib/foreign.ss
View File

@ -1557,11 +1557,11 @@
;; version that uses finalizers, but that leads to calling Scheme from the GC
;; which is not a good idea.
(define killer-executor (make-will-executor))
(define killer-thread
(delay
(thread (lambda () (let loop () (will-execute killer-executor) (loop))))))
(define killer-thread #f)
(define* (register-finalizer obj finalizer)
(force killer-thread)
(unless killer-thread
(set! killer-thread (thread (lambda () (let loop () (will-execute killer-executor) (loop))))))
(will-register killer-executor obj finalizer))
(define-unsafer unsafe!)

31
collects/r5rs/main.ss
View File

@ -1,6 +1,7 @@
(module main scheme/base
(require (for-syntax scheme/base))
(require (for-syntax scheme/base)
(only-in mzscheme transcript-on transcript-off))
(provide (for-syntax syntax-rules ...)
(rename-out
@ -62,7 +63,8 @@
vector? make-vector vector vector-ref vector-set!
char? char=? char<? char>? char<=? char>=?
char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
char-upcase boolean? eqv? equal? force
char-upcase boolean? eqv? equal?
(rename-out [r5rs:force force])
call-with-values values dynamic-wind
(rename-out [meval eval])
scheme-report-environment null-environment interaction-environment)
@ -419,6 +421,26 @@
[(_ test then else)
(if test then else)]))
;; Essentially from Dybvig:
(define-syntax r5rs:delay
(lambda (x)
(syntax-case x ()
((delay exp)
(syntax/loc x (make-promise (lambda () exp)))))))
(define-struct promise (p) #:mutable)
(define (r5rs:force p)
(unless (promise? p)
(raise-type-error 'force "promise" p))
(let ([v (promise-p p)])
(if (procedure? v)
(let ([v (call-with-values v list)])
(when (procedure? (promise-p p))
(set-promise-p! p v))
(apply values (promise-p p)))
(apply values v))))
(provide unquote unquote-splicing
(rename-out [r5rs:quote quote]
[r5rs:quasiquote quasiquote]
@ -426,8 +448,9 @@
[r5rs:lambda lambda]
[r5rs:letrec letrec]
[r5rs:define define]
[r5rs:define-syntax define-syntax])
let and or cond case delay do
[r5rs:define-syntax define-syntax]
[r5rs:delay delay])
let and or cond case do
let* begin set!
let-syntax letrec-syntax
=> else

4
collects/scheme/async-channel.ss Normal file
View File

@ -0,0 +1,4 @@
#lang scheme/base
(require mzlib/async-channel)
(provide (all-from-out mzlib/async-channel))

4
collects/scheme/main.ss
View File

@ -12,6 +12,7 @@
scheme/path
scheme/file
scheme/cmdline
scheme/promise
(for-syntax scheme/base))
(provide (all-from-out scheme/contract
@ -27,5 +28,6 @@
scheme/list
scheme/path
scheme/file
scheme/cmdline)
scheme/cmdline
scheme/promise)
(for-syntax (all-from-out scheme/base))))

3
collects/scheme/mzscheme.ss
View File

@ -14,6 +14,7 @@
"private/old-rp.ss"
"private/old-if.ss"
"private/old-procs.ss"
"promise.ss"
(only "private/cond.ss" old-cond)
"tcp.ss"
"udp.ss"
@ -33,6 +34,7 @@
identifier? ;; from "private/stx.ss"
(all-from "private/qqstx.ss")
(all-from "private/define.ss")
force delay promise?
(all-from-except '#%kernel #%module-begin #%datum
if make-empty-namespace
syntax->datum datum->syntax
@ -48,6 +50,7 @@
(rename free-label-identifier=? module-label-identifier=?)
(rename free-identifier=?* free-identifier=?)
namespace-transformer-require
transcript-on transcript-off
(rename cleanse-path expand-path)
(rename if* if)
make-namespace

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

@ -17,7 +17,8 @@ improve method arity mismatch contract violation error messages?
(require (for-syntax scheme/base)
(for-syntax "contract-opt-guts.ss")
(for-syntax scheme/struct-info)
(for-syntax scheme/list))
(for-syntax scheme/list)
scheme/promise)
(require "contract-arrow.ss"
"contract-guts.ss"

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

@ -86,26 +86,6 @@
(begin e1 e2 ...)
(begin c ... (doloop step ...))))))))))))
;; From Dybvig:
(define-syntax delay
(lambda (x)
(syntax-case x ()
((delay exp)
(syntax/loc x (make-promise (lambda () exp)))))))
(-define-struct promise (p))
(define (force p)
(unless (promise? p)
(raise-type-error 'force "promise" p))
(let ([v (promise-p p)])
(if (procedure? v)
(let ([v (call-with-values v list)])
(when (procedure? (promise-p p))
(set-promise-p! p v))
(apply values (promise-p p)))
(apply values v))))
(define-syntax parameterize
(lambda (stx)
(syntax-case stx ()
@ -346,7 +326,7 @@
(printf "cpu time: ~s real time: ~s gc time: ~s~n" cpu user gc)
(apply values v)))])))
(#%provide case old-case do delay force promise?
(#%provide case old-case do
parameterize parameterize* current-parameterization call-with-parameterization
parameterize-break current-break-parameterization call-with-break-parameterization
with-handlers with-handlers* call-with-exception-handler

11
collects/scheme/private/old-procs.ss
View File

@ -8,7 +8,9 @@
(#%provide make-namespace
free-identifier=?*
namespace-transformer-require)
namespace-transformer-require
transcript-on
transcript-off)
(define reflect-var #f)
@ -33,4 +35,9 @@
(free-identifier=? a b)))
(define (namespace-transformer-require qrs)
(namespace-require `(for-syntax ,qrs))))
(namespace-require `(for-syntax ,qrs)))
(define (transcript-on filename)
(error 'transcript-on "unsupported"))
(define (transcript-off)
(error 'transcript-off "unsupported")))

4
collects/scheme/private/pre-base.ss
View File

@ -25,10 +25,10 @@
stx))
(datum->syntax stx (cdr (syntax-e stx)) stx stx)))
(#%provide (all-from-except "more-scheme.ss" old-case)
(#%provide (all-from-except "more-scheme.ss" old-case fluid-let)
(all-from "misc.ss")
(all-from "define.ss")
(all-from-except "letstx-scheme.ss" -define -define-syntax -define-struct)
(all-from-except "letstx-scheme.ss" -define -define-syntax -define-struct old-cond)
(rename new-lambda lambda)
(rename new-λ λ)
(rename new-define define)

140
collects/scheme/promise.ss Normal file
View File

@ -0,0 +1,140 @@
#lang scheme/base
;;
;; This module implements "lazy promises" and a `force' that is iterated
;; through them.
;; This is similar to the *new* version of srfi-45 -- see the post-finalization
;; discussion at http://srfi.schemers.org/srfi-45/ for more details;
;; specifically, this version is the `lazy2' version from
;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html and (a
;; `lazy3' variant of `force' that deals with multiple values is included and
;; commented). Note: if you use only `force'+`delay' it behaves as in Scheme
;; (except that `force' is identity for non promise values), and `force'+`lazy'
;; are sufficient for implementing the lazy language.
(require (for-syntax scheme/base))
(provide lazy delay force promise?)
(define running
(lambda () (error 'force "reentrant promise")))
(define (promise-printer promise port write?)
(let loop ([p (promise-val promise)])
(cond
[(procedure? p)
(cond [(object-name p)
=> (lambda (n) (fprintf port "#<promise:~a>" n))]
[else (display "#<promise>" port)])]
;; no values
[(null? p) (fprintf port "#<promise!(values)>")]
[(pair? p)
;; single or multiple values
(fprintf port
(if write? "#<promise!~a~s" "#<promise!~a~a")
(if (null? (cdr p))
""
"(values ")
(car p))
(when (pair? (cdr p))
(let ([fmt (if write? " ~s" " ~a")])
(for-each (lambda (x) (fprintf port fmt x)) (cdr p))))
(unless (null? (cdr p))
(display ")" port))
(display ">" port)]
[(promise? p) (loop (promise-val p))] ; hide sharing
[else (loop (list p))])))
(define-struct promise (val)
#:mutable
#:property prop:custom-write promise-printer)
;; <promise> ::=
;; | (promise <thunk>) delayed promise, maybe currently running, maybe an exn promise
;; | (promise (list <object>)) forced promise (possibly multi-valued)
;; | (promise <promise>) shared promise
;; | (promise <object>) forced promise, since values
;; Creates a `composable' promise
;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
(define-syntax (lazy stx)
(syntax-case stx ()
[(lazy expr) (with-syntax ([proc (syntax-property
(syntax/loc stx (lambda () expr))
'inferred-name (syntax-local-name))])
(syntax/loc stx (make-promise proc)))]))
;; Creates a promise that does not compose
;; X = (force (delay X)) = (force (lazy (delay X)))
;; = (force (lazy^n (delay X)))
;; X = (force (force (delay (delay X)))) =/= (force (delay (delay X)))
;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a
;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0)
;; (This is not needed with a lazy language (see the above URL for details),
;; but provided for completeness.)
(define-syntax (delay stx)
(syntax-case stx ()
[(delay expr)
(with-syntax ([proc (syntax-property
(syntax/loc stx (lambda () expr))
'inferred-name (syntax-local-name))])
(syntax/loc stx
(lazy (make-promise (call-with-values proc list)))))]))
;; force iterates on lazy promises (forbid dependency cycles)
;; * (force X) = X for non promises
;; * does not deal with multiple values, since they're not used by the lazy
;; language (but see below)
(define handle-results
(case-lambda
[(single) (values #t single)]
[multi (values #f multi)]))
(define (force promise)
(if (promise? promise)
(let loop ([p (promise-val promise)])
(cond
[(procedure? p)
;; mark root for cycle detection:
(set-promise-val! promise running)
(with-handlers* ([void (lambda (e)
(set-promise-val! promise (lambda () (raise e)))
(raise e))])
(let-values ([(single? vals*)
(call-with-values p
handle-results)])
(if single?
(let loop1 ([val* vals*])
(if (promise? val*)
(let loop2 ([promise* val*])
(let ([p* (promise-val promise*)])
(set-promise-val! promise* promise) ; share with root
(cond [(procedure? p*)
(let-values ([(single? vals)
(call-with-values p*
handle-results)])
(if single?
(loop1 vals)
(begin
(set-promise-val! promise vals)
(apply values vals))))]
[(or (pair? p*) (null? p*))
(set-promise-val! promise p*)
(apply values p*)]
[(promise? p*) (loop2 p*)]
[else p*])))
(begin ; error here for "library approach" (see above URL)
(if (or (null? val*) (pair? val*) (procedure? val*))
(set-promise-val! promise (list val*))
(set-promise-val! promise val*))
val*)))
(begin ; error here for "library approach" (see above URL)
(set-promise-val! promise vals*)
(apply values vals*)))))]
[(or (pair? p) (null? p)) (apply values p)]
[(promise? p) (loop (promise-val p))]
[else p]))
;; different from srfi-45: identity for non-promises
promise))

55
collects/scribblings/reference/async-channels.scrbl Normal file
View File

@ -0,0 +1,55 @@
#lang scribble/doc
@(require "mz.ss"
(for-label scheme/async-channel))
@title[#:tag "async-channel"]{Buffered Asynchronous Channels}
@note-lib-only[scheme/async-channel]
@defproc[(async-channel? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is an asynchronous channel,
@scheme[#f] otherwise.}
@defproc[(make-async-channel [limit (or/c exact-positive-integer? false/c) #f])
async-channel?]{
Returns an asynchronous channel with a buffer limit of @scheme[limit]
items. A get operation blocks when the channel is empty, and a put
operation blocks when the channel has @scheme[limit] items already.
If @scheme[limit] is @scheme[#f], the channel buffer has no limit (so
a put never blocks).
The asynchronous channel value can be used directly with
@scheme[sync]. The channel blocks until @scheme[async-channel-get]
would return a value, and the unblock result is the received value.}
@defproc[(async-channel-get [ach async-channel?]) any/c]{
Blocks until at least one value is available in @scheme[ach], and then
returns the first of the values that were put into
@scheme[async-channel].}
@defproc[(async-channel-try-get [ach async-channel?]) any/c]{
If at least one value is immediately available in @scheme[ach],
returns the first of the values that were put into @scheme[ach]. If
@scheme[async-channel] is empty, the result is @scheme[#f].}
@defproc[(async-channel-put [ach async-channel?][v any/c]) void?]{
Puts @scheme[v] into @scheme[ach], blocking if @scheme[ach]'s buffer
is full until space is available.}
@defproc[(async-channel-put-evt [async-channel channel?][v any/c])
evt?]{
Returns a @tech{synchronizable event} that is blocked while
@scheme[(async-channel-put ach v)] would block. The unblock result is
the event itself. See also @scheme[sync].}

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

@ -7,6 +7,7 @@
@include-section["values.scrbl"]
@include-section["exns.scrbl"]
@include-section["promise.scrbl"]
@include-section["cont.scrbl"]
@include-section["cont-marks.scrbl"]
@include-section["breaks.scrbl"]

11
collects/scribblings/reference/custom-write.scrbl
View File

@ -68,3 +68,14 @@ so that graph and cycle structure can be represented.
(write t))
]
}
@defproc[(custom-write? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] has the @scheme[prop:custom-write]
property, @scheme[#f] otherwise.}
@defproc[(custom-write-accessor [v custom-write?])
(custom-write? output-port? boolean?. -> . any)]{
Returns the custom-write procedure associated with @scheme[v].}

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

@ -496,6 +496,28 @@ The @scheme[continuation] field can be used by a handler to resume the
interrupted computation.}
@defthing[prop:exn:srclocs struct-type-property?]{
A property that identifiers structure types that provide a list of
@scheme[srcloc] values. The property is normally attached to structure
types used to represent exception information.
The property value must be a procedure that accepts a single
value---the structure type instance from which to extract source
locations---and returns a list of @scheme[srcloc]s.}
@defproc[(exn:srclocs? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] has the @scheme[prop:exn:srclocs]
property, @scheme[#f] otherwise.}
@defproc[(exn:srclocs-accessor [v exn:srclocs?])
(exn:srclocs?. -> . (listof srcloc))]{
Returns the @scheme[srcloc]-getting procedure associated with @scheme[v].}
@defstruct[srcloc ([source any/c]
[line (or/c positive-exact-integer? false/c)]

94
collects/scribblings/reference/for.scrbl
View File

@ -5,12 +5,13 @@
@guideintro["for"]{iterations and comprehensions}
The PLT Scheme iteration forms are based on SRFI-42
The @scheme[for] iteration forms are based on SRFI-42
@cite["SRFI-42"].
@section{Iteration and Comprehension Forms}
@defform/subs[(for (for-clause ...) . body)
@defform/subs[(for (for-clause ...) body ...+)
([for-clause [id seq-expr]
[(id ...) seq-expr]
(code:line #:when guard-expr)])]{
@ -49,7 +50,7 @@ wrapped as
@schemeblock[
(when guard-expr
(for (for-clause ...) . body))
(for (for-clause ...) body ...+))
]
using the remaining @scheme[for-clauses].
@ -68,7 +69,7 @@ using the remaining @scheme[for-clauses].
(error "doesn't get here"))
]}
@defform[(for/list (for-clause ...) . body)]{ Iterates like
@defform[(for/list (for-clause ...) body ...+)]{ Iterates like
@scheme[for], but that the last expression of @scheme[body] must
produce a single value, and the result of the @scheme[for/list]
expression is a list of the results in order.
@ -84,7 +85,7 @@ expression is a list of the results in order.
(error "doesn't get here"))
]}
@defform[(for/and (for-clause ...) . body)]{ Iterates like
@defform[(for/and (for-clause ...) body ...+)]{ Iterates like
@scheme[for], but when last expression of @scheme[body] produces
@scheme[#f], then iteration terminates, and the result of the
@scheme[for/and] expression is @scheme[#f]. If the @scheme[body]
@ -101,7 +102,7 @@ result from the last evaluation of @scheme[body].
(error "doesn't get here"))
]}
@defform[(for/or (for-clause ...) . body)]{ Iterates like
@defform[(for/or (for-clause ...) body ...+)]{ Iterates like
@scheme[for], but when last expression of @scheme[body] produces
a value other than @scheme[#f], then iteration terminates, and
the result of the @scheme[for/or] expression is the same
@ -118,7 +119,17 @@ result of the @scheme[for/or] expression is
(error "doesn't get here"))
]}
@defform[(for/first (for-clause ...) . body)]{ Iterates like
@defform[(for/lists (id ...) (for-clause ...) body ...+)]{
Similar to @scheme[for/list], but the last @scheme[body] expression
should produce as many values as given @scheme[id]s, and the result is
as many lists as supplied @scheme[id]s. The @scheme[id]s are bound to
the lists accumulated so far in the @scheme[for-clause]s and
@scheme[body]s.}
@defform[(for/first (for-clause ...) body ...+)]{ Iterates like
@scheme[for], but after @scheme[body] is evaluated the first
time, then the iteration terminates, and the @scheme[for/first]
result is the (single) result of @scheme[body]. If the
@ -133,7 +144,7 @@ result is the (single) result of @scheme[body]. If the
(error "doesn't get here"))
]}
@defform[(for/last (for-clause ...) . body)]{ Iterates like
@defform[(for/last (for-clause ...) body ...+)]{ Iterates like
@scheme[for], but the @scheme[for/last] result is the (single)
result of of the last evaluation of @scheme[body]. If the
@scheme[body] is never evaluated, then the result of the
@ -166,7 +177,7 @@ accumulator values.
(values (+ sum i) (cons (sqrt i) rev-roots)))
]}
@defform[(for* (for-clause ...) . body)]{
@defform[(for* (for-clause ...) body ...+)]{
Like @scheme[for], but with an implicit @scheme[#:when #t] between
each pair of @scheme[for-clauses], so that all sequence iterations are
nested.
@ -177,39 +188,35 @@ nested.
(display (list i j)))
]}
@defform[(for*/list (for-clause ...) . body)]{
Like @scheme[for/list], but with the implicit nesting of @scheme[for*].
@deftogether[(
@defform[(for*/list (for-clause ...) body ...+)]
@defform[(for*/lists (id ...) (for-clause ...) body ...+)]
@defform[(for*/and (for-clause ...) body ...+)]
@defform[(for*/or (for-clause ...) body ...+)]
@defform[(for*/first (for-clause ...) body ...+)]
@defform[(for*/last (for-clause ...) body ...+)]
@defform[(for*/fold ([accum-id init-expr] ...) (for-clause ...) body ...+)]
)]{
Like @scheme[for/list], etc., but with the implicit nesting of
@scheme[for*].
@examples[
(for*/list ([i '(1 2)]
[j "ab"])
(list i j))
]}
@defform[(for*/and (for-clause ...) . body)]{
Like @scheme[for/and], but with the implicit nesting of @scheme[for*].}
@defform[(for*/or (for-clause ...) . body)]{
Like @scheme[for/or], but with the implicit nesting of @scheme[for*].}
@defform[(for*/first (for-clause ...) . body)]{
Like @scheme[for/first], but with the implicit nesting of @scheme[for*].}
@defform[(for*/last (for-clause ...) . body)]{
Like @scheme[for/last], but with the implicit nesting of @scheme[for*].}
@defform[(for*/fold ([accum-id init-expr] ...) (for-clause ...) . body)]{
Like @scheme[for/fold], but with the implicit nesting of @scheme[for*].}
@;------------------------------------------------------------------------
@section{Deriving New Iteration Forms}
@defform[(for/fold/derived orig-datum
([accum-id init-expr] ...) (for-clause ...) . body)]{
([accum-id init-expr] ...) (for-clause ...) body ...+)]{
Like @scheme[fold/fold], but the extra @scheme[orig-datum] is used as the source for all syntax errors.
}
@defform[(for*/fold/derived orig-datum
([accum-id init-expr] ...) (for-clause ...) . body)]{
([accum-id init-expr] ...) (for-clause ...) body ...+)]{
Like @scheme[fold*/fold], but the extra @scheme[orig-datum] is used as the source for all syntax errors.
}
@ -273,3 +280,34 @@ context of the @scheme[:do-in] use. The actual @scheme[loop] binding
and call has additional loop arguments to support iterations in
parallel with the @scheme[:do-in] form, and the other pieces are
similarly accompanied by pieces form parallel iterations.}
@section{Do Loops}
@defform/subs[(do ([id init-expr step-expr-maybe] ...)
(cont?-expr finish-expr ...)
expr ...+)
([step-expr-maybe code:blank
step-expr])]{
Iteratively evaluates the @scheme[expr]s for as long as
@scheme[cont-expr?] returns @scheme[#t].
To initialize the loop, the @scheme[init-expr]s are evaluated in order
and bound to the corresponding @scheme[id]s. The @scheme[id]s are
bound in all expressions within the form other than the
@scheme[init-expr]s.
After he @scheme[id]s are bound, then @scheme[cont?-expr] is
evaluated. If it produces a true value, then each @scheme[expr] is
evaluated for its side-effect. The @scheme[id]s are then updated with
the values of the @scheme[step-expr]s, where the default
@scheme[step-expr] for @scheme[id] is just @scheme[id]. Iteration
continues by evaluating @scheme[cont?-expr].
When @scheme[cont?-expr] produces @scheme[#f], then the
@scheme[finish-expr]s are evaluated in order, and the last one is
evaluated in tail position to produce the overall value for the
@scheme[do] form. If no @scheme[finish-expr] is provided, the value of
the @scheme[do] form is @|void-const|.}

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

@ -49,7 +49,8 @@
[(_ s) (scheme s)]))
(provide exnraise Exn)
(provide refalso moreref Guide guideintro guidesecref)
(provide refalso moreref Guide guideintro guidesecref
HonuManual)
(define (refalso tag . s)
(apply margin-note
@ -73,5 +74,9 @@
(list ".")))))
(define Guide
(italic (guidesecref "top"))))
(italic (guidesecref "top")))
(define HonuManual
(secref #:doc '(lib "scribblings/honu/honu.scrbl") "top")))

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

@ -336,6 +336,21 @@ Returns @scheme[(and (exact-integer? v) (positive? v))].
@examples[(denominator 5) (denominator 34/8) (denominator 2.3) (denominator +inf.0)]}
@defproc[(rationalize [x real?][tolerance real?]) real?]{
Among the real numbers within @scheme[(abs tolerance)] of @scheme[x],
returns the one corresponding to an exact number whose
@scheme[denominator] is smallest. If multiple integers are within
@scheme[tolerance] of @scheme[x], the one closest to @scheme[0] is
used.
@examples[
(rationalize 1/4 1/10)
(rationalize -1/4 1/10)
(rationalize 1/4 1/4)
(rationalize 11/40 1/4)
]}
@; ----------------------------------------
@section{Number Comparison}

16
collects/scribblings/reference/paths.scrbl
View File

@ -478,11 +478,21 @@ Returns a path that is the same as @scheme[path], except that the
suffix for the last element of the path is changed to
@scheme[suffix]. If the last element of @scheme[path] has no suffix,
then @scheme[suffix] is added to the path. A suffix is defined as a
period followed by any number of non-period characters/bytes at the
end of the path element. The @scheme[path] argument can be a path for
any platform, and the result is for the same platform. If
@litchar{.} followed by any number of non-@litchar{.} characters/bytes
at the end of the path element, as long as the path element is not
@scheme[".."] or @scheme["."]. The @scheme[path] argument can be a
path for any platform, and the result is for the same platform. If
@scheme[path] represents a root, the @exnraise[exn:fail:contract].}
@defproc[(path-add-suffix [path path-string?]
[suffix (or/c string? bytes?)])
path?]{
Similar to @scheme[path-replace-suffix], but any existing suffix on
@scheme[path] is preserved by replacing every @litchar{.} in the last
path element with @litchar{_}, and then the @scheme[suffix] is added
to the end.}
@;------------------------------------------------------------------------
@section{More Path Utilities}

42
collects/scribblings/reference/promise.scrbl Normal file
View File

@ -0,0 +1,42 @@
#lang scribble/doc
@(require "mz.ss"
(for-label scheme/promise))
@title{Delayed Evaluation}
@note-lib[scheme/promise]
A @deftech{promise} encapsulates an expression to be evaluated on
demand via @scheme[force]. After a promise has been @scheme[force]d,
every later @scheme[force] of the promise produces the same result.
@defproc[(promise? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a promise, @scheme[#f]
otherwise.}
@defform[(delay expr)]{
Creates a promise that, when @scheme[force]d, evaluates @scheme[expr]
to produce its value.}
@defform[(lazy expr)]{
Like @scheme[delay], except that if @scheme[expr] produces a promise,
then the promise is @scheme[force]d to obtain a value.}
@defproc[(force [v any/c]) any]{
If @scheme[v] is a promise, then the promise is forced to obtain a
value. If the promise has not been forced before, then the result is
recorded in the promise so that future @scheme[force]s on the promise
produce the same value (or values). If forcing the promise raises an
exception, then the exception is similarly recorded so that forcing
the promise will raise the same exception every time.
If @scheme[v] is @scheme[force]d again before the original call to
@scheme[force] returns, then the @exnraise[exn:fail].
If @scheme[v] is not a promise, then it is returned as the result.}

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

@ -138,7 +138,6 @@ on the next character or characters in the input stream as follows:
@dispatch[@cilitchar["#sx"]]{starts a Scheme expression; see @secref["parse-honu"]}
@dispatch[@litchar["#hx"]]{starts a Honu expression; see @secref["parse-honu"]}
@dispatch[@litchar["#honu"]]{starts a Honu module; see @secref["parse-honu"]}
@dispatch[@litchar["#hash"]]{starts a hash table; see @secref["parse-hashtable"]}
@ -758,3 +757,6 @@ By convention, @litchar{#lang} normally appears at the beginning of a
file, possibly after comment forms, to specify the syntax of a module.
@section[#:tag "parse-honu"]{Honu Parsing}
See @|HonuManual| for information on @litchar{#hx} and
@litchar{#sx}.

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

@ -37,15 +37,6 @@ where @schememodname[scheme] includes all of
@;------------------------------------------------------------------------
@section{To Do}
This chapter provides some temporary hyper-link targets.
@subsection[#:tag "async-channel"]{Asynchronous Channels}
@subsection[#:tag "honu"]{Honu}
@;------------------------------------------------------------------------
@(bibliography
(bib-entry #:key "Danvy90"

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

@ -36,6 +36,14 @@ is also controlled by its ancestor inspectors, but no other
inspectors.}
@defproc[(make-sibling-inspector [inspector inspector? (current-inspector)])
inspector?]{
Returns a new inspector that is a subinspector of the same inspector
as @scheme[inspector]. That is, @scheme[inspector] and the result
inspector control mutually disjoint sets of structure types.}
@defparam[current-inspector insp inspector?]{
A parameter that determines the default inspector for newly created

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

@ -25,3 +25,4 @@ for synchronization.}
@include-section["evts.scrbl"]
@include-section["channels.scrbl"]
@include-section["semaphores.scrbl"]
@include-section["async-channels.scrbl"]

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

@ -184,7 +184,7 @@ A parameter that controls printing hash tables; defaults to
@defboolparam[print-honu on?]{
A parameter that controls printing values in an alternate syntax. See
@secref["honu"] for more information.}
@|HonuManual| for more information.}
@defproc*[([(port-write-handler [out output-port?]) (any/c output-port? . -> . any)]

58
collects/scribblings/scribble/manual.scrbl
View File

@ -552,35 +552,47 @@ the containing class/interface.}
@section{Various String Forms}
@defproc[(defterm [pre-content any/c] ...) element?]{Typesets the
given content as a defined term (e.g., in italic). Consider using
@scheme[deftech] instead, though, so that uses of @scheme[tech] can
hyper-link to the definition.}
@tech{decode}d @scheme[pre-content] as a defined term (e.g., in
italic). Consider using @scheme[deftech] instead, though, so that uses
of @scheme[tech] can hyper-link to the definition.}
@defproc[(onscreen [pre-content any/c] ...) element?]{ Typesets the given
content as a string that appears in a GUI, such as the name of a
button.}
@defproc[(onscreen [pre-content any/c] ...) element?]{ Typesets the
@tech{decode}d @scheme[pre-content] as a string that appears in a GUI,
such as the name of a button.}
@defproc[(menuitem [menu-name string?] [item-name string?]) element?]{
Typesets the given combination of a GUI's menu and item name.}
@defproc[(filepath [pre-content any/c] ...) element?]{Typesets the given content
as a file name (e.g., in typewriter font and in in quotes).}
@defproc[(filepath [pre-content any/c] ...) element?]{Typesets the
@tech{decode}d @scheme[pre-content] as a file name (e.g., in
typewriter font and in in quotes).}
@defproc[(exec [pre-content any/c] ...) element?]{Typesets the given content
as a command line (e.g., in typewriter font).}
@defproc[(exec [pre-content any/c] ...) element?]{Typesets the
@tech{decode}d @scheme[pre-content] as a command line (e.g., in
typewriter font).}
@defproc[(envvar [pre-content any/c] ...) element?]{Typesets the given
content as an environment variable (e.g., in typewriter font).}
@tech{decode}d @scheme[pre-content] as an environment variable (e.g.,
in typewriter font).}
@defproc[(Flag [pre-content any/c] ...) element?]{Typesets the given
content as a flag (e.g., in typewriter font with a leading hyphen).}
@tech{decode}d @scheme[pre-content] as a flag (e.g., in typewriter
font with a leading @litchar{-}).}
@defproc[(DFlag [pre-content any/c] ...) element?]{Typesets the given
content a long flag (e.g., in typewriter font with two leading
hyphens).}
@tech{decode}d @scheme[pre-content] a long flag (e.g., in typewriter
font with two leading @litchar{-}s).}
@defproc[(math [pre-content any/c] ...) element?]{The content form of
@scheme[pre-content] is transformed:
@defproc[(PFlag [pre-content any/c] ...) element?]{Typesets the given
@tech{decode}d @scheme[pre-content] as a @litchar{+} flag (e.g., in typewriter
font with a leading @litchar{+}).}
@defproc[(DPFlag [pre-content any/c] ...) element?]{Typesets the given
@tech{decode}d @scheme[pre-content] a long @litchar{+} flag (e.g., in
typewriter font with two leading @litchar{+}s).}
@defproc[(math [pre-content any/c] ...) element?]{The @tech{decode}d
@scheme[pre-content] is further transformed:
@itemize{
@ -606,19 +618,19 @@ hyperlink label.}
@defproc[(seclink [tag string?] [pre-content any/c] ...) element?]{
The content from @scheme[pre-content] is hyperlinked to the section
The @tech{decode}d @scheme[pre-content] is hyperlinked to the section
tagged @scheme[tag].}
@defproc[(schemelink [id symbol?] [pre-content any/c] ...) element?]{
The content from @scheme[pre-content] is hyperlinked to the definition
The @tech{decode}d @scheme[pre-content] is hyperlinked to the definition
of @scheme[id].}
@defproc[(link [url string?] [pre-content any/c] ...) element?]{
The content from @scheme[pre-content] is hyperlinked to @scheme[url].}
The @tech{decode}d @scheme[pre-content] is hyperlinked to @scheme[url].}
@defproc[(elemtag [t tag?] [pre-content any/c] ...) element?]{
@ -629,17 +641,17 @@ The tag @scheme[t] refers to the content form of
@defproc[(elemref [t tag?] [pre-content any/c] ...) element?]{
The content from @scheme[pre-content] is hyperlinked to @scheme[t],
The @tech{decode}d @scheme[pre-content] is hyperlinked to @scheme[t],
which is normally defined using @scheme[elemtag].}
@defproc[(deftech [pre-content any/c] ...) element?]{
Produces an element for the content form of @scheme[pre-content], and
Produces an element for the @tech{decode}d @scheme[pre-content], and
also defines a term that can be referenced elsewhere using
@scheme[tech].
The @scheme[content->string] result of the content form of
The @scheme[content->string] result of the @tech{decode}d
@scheme[pre-content] is used as a key for references, but normalized
as follows:
@ -660,7 +672,7 @@ that differ slightly from a defined form. For example, a definition of
@defproc[(tech [pre-content any/c] ...) element?]{
Produces an element for the content form of @scheme[pre-content], and
Produces an element for the @tech{decode}d @scheme[pre-content], and
hyperlinks it to the definition of the content as established by
@scheme[deftech]. The content's string form is normalized in the same
way as for @scheme[deftech].

6
collects/syntax/zodiac-unit.ss
View File

@ -223,11 +223,7 @@
(get-slot stx (if trans? trans-slot-table slot-table))
trans?
(and b (list-ref b 4))
(and b
((if trans?
identifier-transformer-binding-export-position
identifier-binding-export-position)
stx))))))]
#f))))]
[(#%top . id)
;; Top-level reference:

8
src/mzscheme/src/module.c
View File

@ -284,14 +284,6 @@ void scheme_init_module(Scheme_Env *env)
scheme_make_compiled_syntax(provide_syntax,
provide_expand),
env);
scheme_add_global_keyword("#%provide-for-syntax",
scheme_make_compiled_syntax(provide_syntax,
provide_expand),
env);
scheme_add_global_keyword("#%provide-for-label",
scheme_make_compiled_syntax(provide_syntax,
provide_expand),
env);
REGISTER_SO(quote_symbol);
REGISTER_SO(file_symbol);

34
src/mzscheme/src/portfun.c
View File

@ -107,8 +107,6 @@ static Scheme_Object *current_write_directory(int argc, Scheme_Object *argv[]);
static Scheme_Object *load_on_demand_enabled(int argc, Scheme_Object *argv[]);
#endif
static Scheme_Object *default_load (int, Scheme_Object *[]);
static Scheme_Object *transcript_on(int, Scheme_Object *[]);
static Scheme_Object *transcript_off(int, Scheme_Object *[]);
static Scheme_Object *flush_output (int, Scheme_Object *[]);
static Scheme_Object *open_input_char_string (int, Scheme_Object *[]);
static Scheme_Object *open_input_byte_string (int, Scheme_Object *[]);
@ -685,17 +683,6 @@ scheme_init_port_fun(Scheme_Env *env)
env);
#endif
scheme_add_global_constant ("transcript-on",
scheme_make_prim_w_arity(transcript_on,
"transcript-on",
1, 1),
env);
scheme_add_global_constant ("transcript-off",
scheme_make_prim_w_arity(transcript_off,
"transcript-off",
0, 0),
env);
scheme_add_global_constant("flush-output",
scheme_make_noncm_prim(flush_output,
"flush-output",
@ -4756,27 +4743,6 @@ Scheme_Object *scheme_load(const char *file)
return val;
}
static Scheme_Object *
transcript_on(int argc, Scheme_Object *argv[])
{
if (!SCHEME_PATH_STRINGP(argv[0]))
scheme_wrong_type("transcript-on", SCHEME_PATH_STRING_STR, 0, argc, argv);
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"transcript-on: not supported");
return scheme_void;
}
static Scheme_Object *
transcript_off(int argc, Scheme_Object *argv[])
{
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"transcript-off: not supported");
return scheme_void;
}
static Scheme_Object *
flush_output(int argc, Scheme_Object *argv[])
{

85
src/mzscheme/src/read.c
View File

@ -1500,16 +1500,13 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
case 'a':
honu = 0;
break;
case 'o':
honu = -1;
break;
case 'x':
honu = 1;
break;
default:
if (!params->honu_mode) {
scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation,
"read: expected `a', `u', or `o' after #h");
"read: expected `a' or `x' after #h");
return NULL;
}
honu = 0;
@ -1526,33 +1523,15 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
ReadParams params_copy;
Scheme_Object *v;
if (honu == -1) {
/* Check for "nu", still */
ch = scheme_getc_special_ok(port);
if (ch == 'n') {
ch = scheme_getc_special_ok(port);
if (ch == 'u') {
/* Done */
} else
scheme_read_err(port, stxsrc, line, col, pos, 4, ch, indentation,
"read: expected `u' after #hon");
} else
scheme_read_err(port, stxsrc, line, col, pos, 3, ch, indentation,
"read: expected `nu' after #ho");
}
memcpy(&params_copy, params, sizeof(ReadParams));
params_copy.honu_mode = 1;
if (honu == 1) {
v = read_inner(port, stxsrc, ht, indentation, &params_copy, 0);
if (SCHEME_EOFP(v)) {
scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation,
"read: end-of-file after #hx");
return NULL;
}
} else
v = read_list(port, stxsrc, line, col, pos, EOF, mz_shape_cons, 0, ht, indentation, &params_copy);
v = read_inner(port, stxsrc, ht, indentation, &params_copy, 0);
if (SCHEME_EOFP(v)) {
scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation,
"read: end-of-file after #hx");
return NULL;
}
return v;
} else {
@ -2492,9 +2471,6 @@ static const char *dot_name(ReadParams *params)
}
static Scheme_Object *combine_angle_brackets(Scheme_Object *list);
static Scheme_Object *honu_add_module_wrapper(Scheme_Object *list,
Scheme_Object *stxsrc,
Scheme_Object *port);
/* "(" (or other opener) has already been read */
static Scheme_Object *
@ -2596,9 +2572,6 @@ read_list(Scheme_Object *port,
list = (stxsrc
? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
: list);
if (params->honu_mode && (closer == EOF)) {
list = honu_add_module_wrapper(list, stxsrc, port);
}
list = attach_shape_property(list, stxsrc, params, closer);
return list;
}
@ -2895,50 +2868,6 @@ static Scheme_Object *combine_angle_brackets(Scheme_Object *list)
return list;
}
static Scheme_Object *
honu_add_module_wrapper(Scheme_Object *list, Scheme_Object *stxsrc, Scheme_Object *port)
{
# define cons scheme_make_pair
Scheme_Object *v, *name;
if (stxsrc)
name = stxsrc;
else
name = ((Scheme_Input_Port *)port)->name;
if (SCHEME_CHAR_STRINGP(name))
name = scheme_char_string_to_byte_string_locale(name);
if (SCHEME_PATHP(name)) {
Scheme_Object *base;
int isdir, i;
name = scheme_split_path(SCHEME_BYTE_STR_VAL(name), SCHEME_BYTE_STRLEN_VAL(name), &base, &isdir,
SCHEME_PLATFORM_PATH_KIND);
for (i = SCHEME_BYTE_STRLEN_VAL(name); i--; ) {
if (SCHEME_BYTE_STR_VAL(name)[i] == '.')
break;
}
if (i > 0)
name = scheme_make_sized_path(SCHEME_BYTE_STR_VAL(name), i, 0);
name = scheme_byte_string_to_char_string_locale(name);
name = scheme_intern_exact_char_symbol(SCHEME_CHAR_STR_VAL(name), SCHEME_CHAR_STRLEN_VAL(name));
} else if (!SCHEME_SYMBOLP(name)) {
name = scheme_intern_symbol("unknown");
}
v = cons(scheme_intern_symbol("module"),
cons(name,
cons(cons(scheme_intern_symbol("lib"),
cons(scheme_make_utf8_string("honu-module.ss"),
cons(scheme_make_utf8_string("honu-module"),
scheme_null))),
list)));
# undef cons
if (stxsrc)
v = scheme_datum_to_syntax(v, list, scheme_false, 0, 0);
return v;
}
static Scheme_Object *attach_shape_property(Scheme_Object *list,
Scheme_Object *stxsrc,
ReadParams *params,

4
src/mzscheme/src/schminc.h
View File

@ -11,9 +11,9 @@
EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP
can be set to 1 again. */
#define USE_COMPILED_STARTUP 1
#define USE_COMPILED_STARTUP 0
#define EXPECTED_PRIM_COUNT 891
#define EXPECTED_PRIM_COUNT 887
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

4
src/mzscheme/src/schvers.h
View File

@ -10,12 +10,12 @@
The string and the separate X/Y/Z/W numbers must
be updated consistently. */
#define MZSCHEME_VERSION "3.99.0.4"
#define MZSCHEME_VERSION "3.99.0.5"
#define MZSCHEME_VERSION_X 3
#define MZSCHEME_VERSION_Y 99
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

66
src/mzscheme/src/stxobj.c
View File

@ -469,16 +469,6 @@ void scheme_init_stx(Scheme_Env *env)
1, 1),
env);
scheme_add_global_constant("identifier-binding-export-position",
scheme_make_noncm_prim(module_binding_pos,
"identifier-binding-export-position",
1, 1),
env);
scheme_add_global_constant("identifier-transformer-binding-export-position",
scheme_make_noncm_prim(module_trans_binding_pos,
"identifier-transformer-binding-export-position",
1, 1),
env);
scheme_add_global_constant("syntax-source-module",
scheme_make_folding_prim(syntax_src_module,
@ -5990,8 +5980,7 @@ static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv)
return do_module_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv);
}
static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv,
int dphase, int get_position)
static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv, int dphase)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *a, *m, *nom_mod, *nom_a;
@ -6014,65 +6003,32 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
if (!m)
return scheme_false;
else if (SAME_OBJ(m, scheme_undefined)) {
if (get_position)
return scheme_false;
else
return lexical_symbol;
} else {
if (get_position) {
/* Imported or a "self" variable? */
if (SAME_TYPE(SCHEME_TYPE(m), scheme_module_index_type)
&& SCHEME_FALSEP(((Scheme_Modidx *)m)->path)
&& SCHEME_FALSEP(((Scheme_Modidx *)m)->base)) {
/* self */
return scheme_false;
} else {
/* Imported */
int pos;
m = scheme_module_resolve(m, 0);
pos = scheme_module_export_position(m, scheme_get_env(NULL), a);
if (pos < 0)
return scheme_false;
else
return scheme_make_integer(pos);
}
} else
return CONS(m, CONS(a, CONS(nom_mod,
CONS(nom_a,
CONS(mod_phase ? scheme_true : scheme_false,
scheme_null)))));
}
return lexical_symbol;
} else
return CONS(m, CONS(a, CONS(nom_mod,
CONS(nom_a,
CONS(mod_phase ? scheme_true : scheme_false,
scheme_null)))));
}
static Scheme_Object *module_binding(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-binding", argc, argv, 0, 0);
return do_module_binding("identifier-binding", argc, argv, 0);
}
static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-transformer-binding", argc, argv, 1, 0);
return do_module_binding("identifier-transformer-binding", argc, argv, 1);
}
static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-template-binding", argc, argv, -1, 0);
return do_module_binding("identifier-template-binding", argc, argv, -1);
}
static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-label-binding", argc, argv, MZ_LABEL_PHASE, 0);
}
static Scheme_Object *module_binding_pos(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-binding-export-position", argc, argv, 0, 1);
}
static Scheme_Object *module_trans_binding_pos(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-transformer-binding-export-position", argc, argv, 1, 1);
return do_module_binding("identifier-label-binding", argc, argv, MZ_LABEL_PHASE);
}
static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv)