revise scribble/srcdoc so it is extensible; tweak bytecode optimizer to drop more omittable expressions
svn: r9028
This commit is contained in:
Matthew Flatt
parent
3f8d2d20f7
commit
f5e0fd35f5
|
|
@ -30,6 +30,7 @@
|
|||
dynext/file
|
||||
dynext/compile
|
||||
dynext/link
|
||||
scheme/pretty
|
||||
(lib "pack.ss" "setup")
|
||||
(lib "getinfo.ss" "setup")
|
||||
setup/dirs)
|
||||
|
|
@ -138,7 +139,10 @@
|
|||
(,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-zo-suffix)))]
|
||||
[("--collection-zos")
|
||||
,(lambda (f) 'collection-zos)
|
||||
(,(format "Compile specified collection to ~a files" (extract-suffix append-zo-suffix)))]]
|
||||
((,(format "Compile specified collection to ~a files" (extract-suffix append-zo-suffix)) ""))]
|
||||
[("--expand")
|
||||
,(lambda (f) 'expand)
|
||||
(,(format "Write macro-expanded Scheme source(s) to stdout"))]]
|
||||
[help-labels ""]
|
||||
[once-any
|
||||
[("--3m")
|
||||
|
|
@ -461,6 +465,23 @@
|
|||
((compile-zos prefix) source-files (if (auto-dest-dir)
|
||||
'auto
|
||||
(dest-dir)))]
|
||||
[(expand)
|
||||
(for-each (lambda (src-file)
|
||||
(let ([src-file (path->complete-path src-file)])
|
||||
(let-values ([(base name dir?) (split-path src-file)])
|
||||
(parameterize ([current-load-relative-directory base]
|
||||
[current-namespace (make-base-namespace)]
|
||||
[read-accept-reader #t])
|
||||
(call-with-input-file*
|
||||
src-file
|
||||
(lambda (in)
|
||||
(port-count-lines! in)
|
||||
(let loop ()
|
||||
(let ([e (read-syntax src-file in)])
|
||||
(unless (eof-object? e)
|
||||
(pretty-print (syntax->datum (expand e)))
|
||||
(loop))))))))))
|
||||
source-files)]
|
||||
[(make-zo)
|
||||
(let ([n (make-base-empty-namespace)]
|
||||
[mc (dynamic-require 'mzlib/cm
|
||||
|
|
|
|||
|
|
@ -27,29 +27,29 @@
|
|||
(define GifVersionPrefix #"GIF89a")
|
||||
|
||||
(provide/doc
|
||||
[gif-stream? ([v any/c] . -> . boolean?)
|
||||
@{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write],
|
||||
@scheme[#f] otherwise.}]
|
||||
[image-ready-gif-stream? ([v any/c] . -> . boolean?)
|
||||
@{Returns @scheme[#t] if @scheme[v] is a GIF stream that is not in
|
||||
@scheme['done] mode, @scheme[#f] otherwise.}]
|
||||
[image-or-control-ready-gif-stream? ([v any/c] . -> . boolean?)
|
||||
@{Returns @scheme[#t] if @scheme[v] is a GIF stream that is in
|
||||
@scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.}]
|
||||
[empty-gif-stream? ([v any/c] . -> . boolean?)
|
||||
@{Returns @scheme[#t] if @scheme[v] is a GIF stream that in
|
||||
@scheme['init] mode, @scheme[#f] otherwise.}]
|
||||
[gif-colormap? ([v any/c] . -> . boolean?)
|
||||
@{Returns @scheme[#t] if @scheme[v] represets a colormap, @scheme[#f] otherwise.
|
||||
A colormap is a list whose size is a power of @math{2} between @math{2^1} and @math{2^8},
|
||||
and whose elements are vectors of size 3 containing colors
|
||||
(i.e., exact integers between @math{0} and @math{255} inclusive).}]
|
||||
[color? ([v any/c]. -> . boolean?)
|
||||
@{The same as @scheme[byte?].}]
|
||||
[dimension? ([v any/c]. -> . boolean?)
|
||||
@{Returns @scheme[#t] if @scheme[v] is an exact integer between
|
||||
@scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f]
|
||||
otherwise.}])
|
||||
(proc-doc gif-stream? (([v any/c]) () . ->d . [_ boolean?])
|
||||
@{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write],
|
||||
@scheme[#f] otherwise.})
|
||||
(proc-doc image-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?])
|
||||
@{Returns @scheme[#t] if @scheme[v] is a GIF stream that is not in
|
||||
@scheme['done] mode, @scheme[#f] otherwise.})
|
||||
(proc-doc image-or-control-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?])
|
||||
@{Returns @scheme[#t] if @scheme[v] is a GIF stream that is in
|
||||
@scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.})
|
||||
(proc-doc empty-gif-stream? (([v any/c]) () . ->d . [_ boolean?])
|
||||
@{Returns @scheme[#t] if @scheme[v] is a GIF stream that in
|
||||
@scheme['init] mode, @scheme[#f] otherwise.})
|
||||
(proc-doc gif-colormap? (([v any/c]) () . ->d . [_ boolean?])
|
||||
@{Returns @scheme[#t] if @scheme[v] represets a colormap, @scheme[#f] otherwise.
|
||||
A colormap is a list whose size is a power of @math{2} between @math{2^1} and @math{2^8},
|
||||
and whose elements are vectors of size 3 containing colors
|
||||
(i.e., exact integers between @math{0} and @math{255} inclusive).})
|
||||
(proc-doc color? (([v any/c]) () . ->d . [_ boolean?])
|
||||
@{The same as @scheme[byte?].})
|
||||
(proc-doc dimension? (([v any/c]) () . ->d . [_ boolean?])
|
||||
@{Returns @scheme[#t] if @scheme[v] is an exact integer between
|
||||
@scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f]
|
||||
otherwise.}))
|
||||
|
||||
(define-struct gif-stream (port
|
||||
SWidth
|
||||
|
|
@ -104,8 +104,8 @@
|
|||
(define (WRITE g bytes)
|
||||
(write-bytes bytes (gif-stream-port g)))
|
||||
|
||||
(provide/doc [gif-state ([stream gif-stream?] . -> . symbol?)
|
||||
@{Returns the state of @scheme[stream].}])
|
||||
(provide/doc (proc-doc gif-state (([stream gif-stream?]) () . ->d . [_ symbol?])
|
||||
@{Returns the state of @scheme[stream].}))
|
||||
(define (gif-state GifFile)
|
||||
(gif-stream-FileState GifFile))
|
||||
|
||||
|
|
@ -113,13 +113,15 @@
|
|||
;; * This routine should be called before any other EGif calls, immediately
|
||||
;; * follows the GIF file openning.
|
||||
;; *****************************************************************************/
|
||||
(provide/doc [gif-start
|
||||
([out output-port?]
|
||||
[w dimension?]
|
||||
[h dimension?]
|
||||
[bg-color color?]
|
||||
[cmap (or/c false/c gif-colormap?)]
|
||||
. -> . gif-stream?)
|
||||
(provide/doc (proc-doc
|
||||
gif-start
|
||||
(([out output-port?]
|
||||
[w dimension?]
|
||||
[h dimension?]
|
||||
[bg-color color?]
|
||||
[cmap (or/c false/c gif-colormap?)])
|
||||
()
|
||||
. ->d . [_ gif-stream?])
|
||||
@{Writes the start of a GIF file to the given output port, and returns
|
||||
a GIF stream that adds to the output port.
|
||||
|
||||
|
|
@ -133,7 +135,7 @@
|
|||
|
||||
A global colormap need not be supplied, in which case a colormap must
|
||||
be supplied for each image. Beware that the bg-color is ill-defined if
|
||||
a global colormap is not provided.}])
|
||||
a global colormap is not provided.}))
|
||||
(define (gif-start port
|
||||
Width
|
||||
Height
|
||||
|
|
@ -186,16 +188,18 @@
|
|||
;; * This routine should be called before any attempt to dump an image - any
|
||||
;; * call to any of the pixel dump routines.
|
||||
;; *****************************************************************************/
|
||||
(provide/doc [gif-add-image
|
||||
([stream image-ready-gif-stream?]
|
||||
[left dimension?]
|
||||
[top dimension?]
|
||||
[width dimension?]
|
||||
[height dimension?]
|
||||
[interlaced? any/c]
|
||||
[cmap (or/c false/c gif-colormap?)]
|
||||
[bstr bytes?]
|
||||
. -> . void?)
|
||||
(provide/doc (proc-doc
|
||||
gif-add-image
|
||||
(([stream image-ready-gif-stream?]
|
||||
[left dimension?]
|
||||
[top dimension?]
|
||||
[width dimension?]
|
||||
[height dimension?]
|
||||
[interlaced? any/c]
|
||||
[cmap (or/c false/c gif-colormap?)]
|
||||
[bstr bytes?])
|
||||
()
|
||||
. ->d . [_ void?])
|
||||
@{Writes an image to the given GIF stream. The @scheme[left], @scheme[top],
|
||||
@scheme[width], and @scheme[height] values specify the location and
|
||||
size of the image within the overall GIF image's virtual space.
|
||||
|
|
@ -224,7 +228,7 @@
|
|||
colormap's length, if the @scheme[bstr] length is not @scheme[width] times
|
||||
@scheme[height], or if the @scheme[top], @scheme[left], @scheme[width], and
|
||||
@scheme[height] dimensions specify a region beyond the overall GIF image's
|
||||
virtual space.}])
|
||||
virtual space.}))
|
||||
(define (gif-add-image GifFile
|
||||
Left
|
||||
Top
|
||||
|
|
@ -293,13 +297,15 @@
|
|||
;;/******************************************************************************
|
||||
;; * This routine should be called to add graphic control before the next image
|
||||
;; *****************************************************************************/
|
||||
(provide/doc [gif-add-control
|
||||
([stream image-or-control-ready-gif-stream?]
|
||||
[disposal (one-of/c 'keep 'restore-bg 'restore-prev)]
|
||||
[wait-for-input? any/c]
|
||||
[delay dimension?]
|
||||
[transparent (or/c false/c color?)]
|
||||
. -> . any)
|
||||
(provide/doc (proc-doc
|
||||
gif-add-control
|
||||
(([stream image-or-control-ready-gif-stream?]
|
||||
[disposal (one-of/c 'keep 'restore-bg 'restore-prev)]
|
||||
[wait-for-input? any/c]
|
||||
[delay dimension?]
|
||||
[transparent (or/c false/c color?)])
|
||||
()
|
||||
. ->d . [_ void?])
|
||||
@{Writes an image-control command to a GIF stream. Such a control must
|
||||
appear just before an image, and it applies to the following image.
|
||||
|
||||
|
|
@ -332,7 +338,7 @@
|
|||
follow image (as opposed to the color specified by the colormap for the index).
|
||||
|
||||
An exception is raised if a control is already added to @scheme[stream]
|
||||
without a corresponding image.}])
|
||||
without a corresponding image.}))
|
||||
|
||||
(define (gif-add-control GifFile
|
||||
Disposal
|
||||
|
|
@ -359,17 +365,19 @@
|
|||
;; * This routine should be called to add the "loop" graphic control
|
||||
;; before adding any images
|
||||
;; *****************************************************************************/
|
||||
(provide/doc [gif-add-loop-control
|
||||
([stream empty-gif-stream?]
|
||||
[iteration dimension?]
|
||||
. -> . any)
|
||||
(provide/doc (proc-doc
|
||||
gif-add-loop-control
|
||||
(([stream empty-gif-stream?]
|
||||
[iteration dimension?])
|
||||
()
|
||||
. ->d . [_ void?])
|
||||
@{Writes a control command to a GIF stream for which no images or other
|
||||
commands have already been written. The command causes the animating
|
||||
sequence of images in the GIF to be repeated `iteration-dimension'
|
||||
times, where 0 can be used to mean ``infinity.''
|
||||
|
||||
An exception is raise if some control or image has been added to the
|
||||
stream already.}])
|
||||
stream already.}))
|
||||
(define (gif-add-loop-control GifFile
|
||||
Iterations)
|
||||
(WRITE GifFile #"\x21\xFF\x0BNETSCAPE2.0\x03\x01")
|
||||
|
|
@ -380,14 +388,16 @@
|
|||
;;/******************************************************************************
|
||||
;; * This routine should be called to add arbitrary comment text
|
||||
;; *****************************************************************************/
|
||||
(provide/doc [gif-add-comment
|
||||
([stream image-or-control-ready-gif-stream?]
|
||||
[bstr bytes?]
|
||||
. -> . any)
|
||||
(provide/doc (proc-doc
|
||||
gif-add-comment
|
||||
(([stream image-or-control-ready-gif-stream?]
|
||||
[bstr bytes?])
|
||||
()
|
||||
. ->d . [_ void?])
|
||||
@{Adds a generic comment to the GIF stream.
|
||||
|
||||
An exception is raised if an image-control command was just written to
|
||||
the stream (so that an image is required next).}])
|
||||
the stream (so that an image is required next).}))
|
||||
(define (gif-add-comment GifFile
|
||||
Str)
|
||||
(WRITE GifFile #"\x21\xFE")
|
||||
|
|
@ -403,15 +413,17 @@
|
|||
;;/******************************************************************************
|
||||
;; * This routine should be called last, to end GIF file.
|
||||
;; *****************************************************************************/
|
||||
(provide/doc [gif-end
|
||||
([stream image-or-control-ready-gif-stream?]
|
||||
. -> . any)
|
||||
(provide/doc (proc-doc
|
||||
gif-end
|
||||
(([stream image-or-control-ready-gif-stream?])
|
||||
()
|
||||
. ->d . [_ void?])
|
||||
@{Finishes
|
||||
writing a GIF file. The GIF stream's output port is not
|
||||
automatically closed.
|
||||
|
||||
An exception is raised if an image-control command was just written to
|
||||
the stream (so that an image is required next).}])
|
||||
the stream (so that an image is required next).}))
|
||||
(define (gif-end GifFile)
|
||||
(WRITE GifFile #";")
|
||||
(set-gif-stream-FileState! GifFile 'done))
|
||||
|
|
@ -556,36 +568,38 @@
|
|||
(zero? (remainder (bytes-length b) 4))))
|
||||
|
||||
(provide/doc
|
||||
[quantize ([bstr argb-bytes?]
|
||||
. -> .
|
||||
(values bytes? gif-colormap? (or/c false/c color?)))
|
||||
(proc-doc quantize
|
||||
(([bstr argb-bytes?])
|
||||
()
|
||||
. ->d .
|
||||
(values [_ bytes?] [_ gif-colormap?] [_ (or/c false/c color?)]))
|
||||
@{Each
|
||||
image in a GIF stream is limited to 256 colors, including the
|
||||
transparent ``color,'' if any. The @scheme[quantize] function helps converts a
|
||||
24-bit image (plus alpha channel) into an indexed-color image,reducing
|
||||
the number of colors if necessary.
|
||||
|
||||
|
||||
Given a set of pixels expressed in ARGB format
|
||||
(i.e., each four bytes is a set of values for one pixel: alpha, red, blue, and green),
|
||||
@scheme[quantize] produces produces
|
||||
|
||||
|
||||
@(itemize
|
||||
@item{bytes for the image (i.e., a array of colors, expressed as a byte string)}
|
||||
@item{a colormap}
|
||||
@item{either @scheme[#f] or a color index for the transparent ``color''})
|
||||
|
||||
|
||||
The conversion treats alpha values less than 128 as transparent
|
||||
pixels, and other alpha values as solid.
|
||||
|
||||
|
||||
The quantization process first attempts to use all (non-transparent)
|
||||
colors in the image. if that fails, it reduces the image to 12-bit
|
||||
color (3 bits per each of red, green, and blue) by rounding up pixel
|
||||
values, and tries again. If that fails, it reduces the image to 6-bit
|
||||
color (2 bits per each of red, green, and blue).
|
||||
|
||||
|
||||
To convert a collection of images all with the same quantization,
|
||||
simply append them for the input of a single call of @scheme[quantize], and
|
||||
then break apart the result bytes.}])
|
||||
then break apart the result bytes.}))
|
||||
(define (quantize argb)
|
||||
(let* ([len (quotient (bytes-length argb) 4)]
|
||||
[result (make-bytes len)]
|
||||
|
|
|
|||
|
|
@ -35,16 +35,14 @@
|
|||
(mod-beg
|
||||
content ...))
|
||||
(with-syntax ([(content ...)
|
||||
(map
|
||||
strip-context
|
||||
(apply
|
||||
append
|
||||
(map (lambda (c)
|
||||
(syntax-case c (#%plain-app void quote-syntax provide/doc)
|
||||
[(#%plain-app void (quote-syntax (provide/doc spec ...)))
|
||||
(syntax->list #'(spec ...))]
|
||||
[_ null]))
|
||||
(syntax->list #'(content ...)))))]
|
||||
(apply
|
||||
append
|
||||
(map (lambda (c)
|
||||
(syntax-case c (#%plain-app void quote-syntax provide/doc)
|
||||
[(#%plain-app void (quote-syntax (provide/doc spec ...)))
|
||||
(syntax->list #'(spec ...))]
|
||||
[_ null]))
|
||||
(syntax->list #'(content ...))))]
|
||||
[(req ...)
|
||||
(map
|
||||
strip-context
|
||||
|
|
@ -57,16 +55,34 @@
|
|||
[(#%plain-app void (quote-syntax (require/doc spec ...)))
|
||||
(syntax->list #'(spec ...))]
|
||||
[_ null]))
|
||||
(syntax->list #'(content ...)))))])
|
||||
(syntax->list #'(content ...)))))]
|
||||
[orig-tag (datum->syntax #f 'orig)])
|
||||
#`(begin
|
||||
(#%require (for-label #,(strip-context #'lang))
|
||||
(for-label #,(strip-context #'orig-path))
|
||||
req ...)
|
||||
(def-it content) ...))])))]))
|
||||
(def-it orig-tag content) ...))])))]))
|
||||
|
||||
(define-syntax def-it
|
||||
(syntax-rules ()
|
||||
[(_ ((rename old-id id) contract desc))
|
||||
(def-it (id contract desc))]
|
||||
[(_ (id (-> arg ... result) desc))
|
||||
(defproc (id arg ...) result . desc)]))
|
||||
(define-for-syntax (revise-context c orig-tag new-tag tag)
|
||||
(cond
|
||||
[(syntax? c)
|
||||
(datum->syntax
|
||||
(if (bound-identifier=? tag (datum->syntax c 'tag))
|
||||
new-tag
|
||||
orig-tag)
|
||||
(revise-context (syntax-e c) orig-tag new-tag tag)
|
||||
c)]
|
||||
[(pair? c) (cons (revise-context (car c) orig-tag new-tag tag)
|
||||
(revise-context (cdr c) orig-tag new-tag tag))]
|
||||
[else c]))
|
||||
|
||||
(define-syntax (def-it stx)
|
||||
(syntax-local-introduce
|
||||
(syntax-case (syntax-local-introduce stx) ()
|
||||
[(_ orig-path (reqs doc tag))
|
||||
(let ([new-tag ((make-syntax-introducer)
|
||||
(datum->syntax #'orig-path 'new-tag))]
|
||||
[orig-tag #'orig-path])
|
||||
#`(begin
|
||||
(require . #,(revise-context #'reqs orig-tag new-tag #'tag))
|
||||
#,(revise-context #'doc orig-tag new-tag #'tag)))])))
|
||||
|
|
|
|||
|
|
@ -713,7 +713,9 @@
|
|||
(raise-syntax-error 'defproc "bad prototype" stx)]))
|
||||
|
||||
(define-syntax (result-contract stx)
|
||||
(syntax-case stx ()
|
||||
(syntax-case stx (values)
|
||||
[(_ (values c ...))
|
||||
#'(list (schemeblock0 c) ...)]
|
||||
[(_ c)
|
||||
(if (string? (syntax-e #'c))
|
||||
(raise-syntax-error
|
||||
|
|
@ -1233,7 +1235,29 @@
|
|||
(element-width tagged))]
|
||||
[(short?) (or (flat-size . < . 40)
|
||||
((length args) . < . 2))]
|
||||
[(res) (result-contract)]
|
||||
[(res) (let ([res (result-contract)])
|
||||
(if (list? res)
|
||||
;; multiple results
|
||||
(if (null? res)
|
||||
'nbsp
|
||||
(let ([w (apply max 0 (map flow-element-width res))])
|
||||
(if (or (ormap table? res)
|
||||
(w . > . 30))
|
||||
(make-table
|
||||
#f
|
||||
(map (lambda (fe)
|
||||
(list (make-flow (list fe))))
|
||||
res))
|
||||
(make-table
|
||||
#f
|
||||
(list
|
||||
(let loop ([res res])
|
||||
(if (null? (cdr res))
|
||||
(list (make-flow (list (car res))))
|
||||
(list* (make-flow (list (car res)))
|
||||
(to-flow (hspace 1))
|
||||
(loop (cdr res))))))))))
|
||||
res))]
|
||||
[(result-next-line?) ((+ (if short?
|
||||
flat-size
|
||||
(+ (prototype-size args max max)
|
||||
|
|
|
|||
15
collects/scribble/provide-doc-transform.ss
Normal file
15
collects/scribble/provide-doc-transform.ss
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base))
|
||||
|
||||
(provide define-provide/doc-transformer
|
||||
(for-syntax
|
||||
provide/doc-transformer?
|
||||
provide/doc-transformer-proc))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct provide/doc-transformer (proc) #:omit-define-syntaxes))
|
||||
|
||||
(define-syntax-rule (define-provide/doc-transformer id rhs)
|
||||
(define-syntax id
|
||||
(make-provide/doc-transformer rhs)))
|
||||
|
|
@ -1,27 +1,83 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/contract)
|
||||
(require scheme/contract
|
||||
(for-syntax scheme/base)
|
||||
"provide-doc-transform.ss")
|
||||
|
||||
(provide require/doc
|
||||
provide/doc)
|
||||
provide/doc
|
||||
proc-doc)
|
||||
|
||||
(define-syntax-rule (require/doc spec ...)
|
||||
(void (quote-syntax (require/doc spec ...))))
|
||||
|
||||
(define-syntax-rule (provide/doc [id contract desc] ...)
|
||||
(begin
|
||||
(void (quote-syntax (provide/doc [id contract desc] ...)))
|
||||
(provide/contracted [id (strip-names contract)]) ...))
|
||||
(define-syntax (provide/doc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form ...)
|
||||
(let ([forms (syntax->list #'(form ...))])
|
||||
(with-syntax ([((for-provide/contract for-docs) ...)
|
||||
(map (lambda (form)
|
||||
(syntax-case form ()
|
||||
[(id . _)
|
||||
(identifier? #'id)
|
||||
(let ([t (syntax-local-value #'id (lambda () #f))])
|
||||
(unless (provide/doc-transformer? t)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not bound as a provide/doc transformer"
|
||||
stx
|
||||
#'id))
|
||||
(let* ([i (make-syntax-introducer)]
|
||||
[i2 (lambda (x) (syntax-local-introduce (i x)))])
|
||||
(let-values ([(p/c d req/d) ((provide/doc-transformer-proc t)
|
||||
(i (syntax-local-introduce form)))])
|
||||
(list (i2 p/c) (list (i2 req/d) (i2 d) (i2 (quote-syntax tag)))))))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a provide/doc sub-form"
|
||||
stx
|
||||
form)]))
|
||||
forms)])
|
||||
(with-syntax ([(p/c ...)
|
||||
(map (lambda (form f)
|
||||
(quasisyntax/loc form
|
||||
(provide/contract #,f)))
|
||||
forms
|
||||
(syntax->list #'(for-provide/contract ...)))])
|
||||
#'(begin
|
||||
p/c ...
|
||||
(void (quote-syntax (provide/doc for-docs ...)))))))]))
|
||||
|
||||
(define-syntax provide/contracted
|
||||
(syntax-rules (->)
|
||||
[(_ [(rename orig-id new-id) contract])
|
||||
(provide/contract (rename orig-id new-id contract))]
|
||||
[(_ [id contract])
|
||||
(provide/contract [id contract])]))
|
||||
(define-provide/doc-transformer proc-doc
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id contract desc)
|
||||
(with-syntax ([(arg ...)
|
||||
(syntax-case #'contract (->d)
|
||||
[(->d (req ...) () result)
|
||||
#'(req ...)]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"unsupported procedure contract form (arguments)"
|
||||
stx
|
||||
#'contract)])]
|
||||
[result
|
||||
(syntax-case #'contract (->d)
|
||||
[(->d reqs opts (values [name res] ...))
|
||||
#'(values res ...)]
|
||||
[(->d reqs opts [name res])
|
||||
#'res]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"unsupported procedure contract form (arguments)"
|
||||
stx
|
||||
#'contract)])])
|
||||
(values
|
||||
#'[id contract]
|
||||
#'(defproc (id arg ...) result . desc)
|
||||
#'(scribble/manual)))])))
|
||||
|
||||
(define-syntax strip-names
|
||||
(syntax-rules (->)
|
||||
[(_ (-> [id contract] ... result))
|
||||
(-> contract ... result)]
|
||||
[(_ other) other]))
|
||||
|
||||
|
|
|
|||
|
|
@ -67,7 +67,8 @@ If the server cannot be started by @scheme[tcp-listen], the
|
|||
[local-hostname (or/c string? false/c) #f]
|
||||
[local-port-no (or/c (and/c nonnegative-exact-integer?
|
||||
(integer-in 1 65535))
|
||||
false/c)])
|
||||
false/c)
|
||||
#f])
|
||||
(values input-port? output-port?)]{
|
||||
|
||||
Attempts to connect as a client to a listening server. The
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ between different processes.
|
|||
@defproc[(make-pipe [limit positive-exact-integer? #f]
|
||||
[input-name any/c 'pipe]
|
||||
[output-name any/c 'pipe])
|
||||
any]{
|
||||
(values input-port? output-port?)]{
|
||||
|
||||
Returns two port values: the first port is an input port and the
|
||||
second is an output port. Data written to the output port is read from
|
||||
|
|
@ -28,7 +28,7 @@ port's capacity until the peeked bytes are read.)
|
|||
The optional @scheme[input-name] and @scheme[output-name] are used
|
||||
as the names for the returned input and out ports, respectively.}
|
||||
|
||||
@defproc[(pipe-content-length [pipe-port port?]) any]{
|
||||
@defproc[(pipe-content-length [pipe-port port?]) exact-nonnegative-integer?]{
|
||||
|
||||
Returns the number of bytes contained in a pipe, where
|
||||
@scheme[pipe-port] is either of the pipe's ports produced by
|
||||
|
|
|
|||
|
|
@ -609,6 +609,24 @@
|
|||
(define foo integer?)
|
||||
(display #t)))
|
||||
|
||||
(test-comp '(module m mzscheme
|
||||
(void 10))
|
||||
'(module m mzscheme))
|
||||
|
||||
(test-comp '(module m mzscheme
|
||||
(void (quote-syntax unused!)))
|
||||
'(module m mzscheme))
|
||||
|
||||
(test-comp '(module m mzscheme
|
||||
(values 1 2))
|
||||
'(module m mzscheme))
|
||||
|
||||
(test-comp '(module m mzscheme
|
||||
(printf "pre\n")
|
||||
(void 10))
|
||||
'(module m mzscheme
|
||||
(printf "pre\n")))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Check bytecode verification of lifted functions
|
||||
|
||||
|
|
|
|||
|
|
@ -903,6 +903,20 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved)
|
|||
goto try_again;
|
||||
}
|
||||
|
||||
if ((vtype == scheme_compiled_let_void_type)) {
|
||||
/* recognize another (let ([x <omittable>]) ...) pattern: */
|
||||
Scheme_Let_Header *lh = (Scheme_Let_Header *)o;
|
||||
if ((lh->count == 1) && (lh->num_clauses == 1)) {
|
||||
if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) {
|
||||
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
|
||||
if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved)) {
|
||||
o = lv->body;
|
||||
goto try_again;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ((vtype == scheme_letrec_type)) {
|
||||
o = ((Scheme_Letrec *)o)->body;
|
||||
goto try_again;
|
||||
|
|
@ -937,6 +951,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved)
|
|||
return 1;
|
||||
}
|
||||
}
|
||||
/* (values <omittable> ...) */
|
||||
if ((app->num_args == vals) || (vals < 0)) {
|
||||
if (SAME_OBJ(scheme_values_func, app->args[0])) {
|
||||
int i;
|
||||
|
|
@ -947,24 +962,34 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved)
|
|||
return 1;
|
||||
}
|
||||
}
|
||||
/* (void <omittable> ...) */
|
||||
if ((vals == 1) || (vals < 0)) {
|
||||
|
||||
if (SAME_OBJ(scheme_void_proc, app->args[0])) {
|
||||
int i;
|
||||
for (i = app->num_args; i--; ) {
|
||||
if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved))
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ((vtype == scheme_application2_type)) {
|
||||
/* (values <omittable>) or (void <omittable>) */
|
||||
if ((vals == 1) || (vals < 0)) {
|
||||
Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
|
||||
if (SAME_OBJ(scheme_values_func, app->rator)) {
|
||||
if (SAME_OBJ(scheme_values_func, app->rator)
|
||||
|| SAME_OBJ(scheme_void_proc, app->rator)) {
|
||||
if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved))
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if ((vtype == scheme_application3_type)) {
|
||||
/* (values <omittable> <omittable>) */
|
||||
if ((vals == 2) || (vals < 0)) {
|
||||
Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
|
||||
if (SAME_OBJ(scheme_values_func, app->rator)) {
|
||||
|
|
@ -973,7 +998,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved)
|
|||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
/* (void <omittable> <omittable>) */
|
||||
if ((vals == 1) || (vals < 0)) {
|
||||
Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
|
||||
if (SAME_OBJ(scheme_void_proc, app->rator)) {
|
||||
if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved)
|
||||
&& scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved))
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
|
|
|||
|
|
@ -4323,7 +4323,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
|
|||
}
|
||||
}
|
||||
} else {
|
||||
cont = scheme_omittable_expr(e, 1, -1, 0);
|
||||
cont = scheme_omittable_expr(e, -1, -1, 0);
|
||||
}
|
||||
if (i_m + 1 == cnt)
|
||||
cont = 0;
|
||||
|
|
@ -4380,6 +4380,31 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
|
|||
}
|
||||
}
|
||||
|
||||
/* Check one more time for expressions that we can omit: */
|
||||
{
|
||||
int can_omit = 0;
|
||||
for (i_m = 0; i_m < cnt; i_m++) {
|
||||
/* Optimize this expression: */
|
||||
e = SCHEME_VEC_ELS(m->body)[i_m];
|
||||
if (scheme_omittable_expr(e, -1, -1, 0)) {
|
||||
can_omit++;
|
||||
}
|
||||
}
|
||||
if (can_omit) {
|
||||
Scheme_Object *vec;
|
||||
int j = 0;
|
||||
vec = scheme_make_vector(cnt - can_omit, NULL);
|
||||
for (i_m = 0; i_m < cnt; i_m++) {
|
||||
/* Optimize this expression: */
|
||||
e = SCHEME_VEC_ELS(m->body)[i_m];
|
||||
if (!scheme_omittable_expr(e, -1, -1, 0)) {
|
||||
SCHEME_VEC_ELS(vec)[j++] = e;
|
||||
}
|
||||
}
|
||||
m->body = vec;
|
||||
}
|
||||
}
|
||||
|
||||
/* Exp-time body was optimized during compilation */
|
||||
|
||||
return scheme_make_syntax_compiled(MODULE_EXPD, data);
|
||||
|
|
@ -5724,9 +5749,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
Scheme_Object *prev = NULL, *next;
|
||||
for (p = first; !SCHEME_NULLP(p); p = next) {
|
||||
next = SCHEME_CDR(p);
|
||||
if (scheme_omittable_expr(SCHEME_CAR(p), 1, -1, 0)) {
|
||||
if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0)) {
|
||||
if (prev)
|
||||
SCHEME_CDR(p) = next;
|
||||
SCHEME_CDR(prev) = next;
|
||||
else
|
||||
first = next;
|
||||
} else
|
||||
|
|
|
|||
|
|
@ -3227,7 +3227,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
|
|||
/* Optimized away all clauses? */
|
||||
if (!head->num_clauses)
|
||||
return head->body;
|
||||
|
||||
|
||||
if (is_rec && !not_simply_let_star) {
|
||||
/* We can simplify letrec to let* */
|
||||
SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user