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

sync to trunk

Browse Source 
svn: r14602
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-24 21:30:40 +00:00
commit 29e123ccf3
96 changed files with 3356 additions and 1908 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/browser/browser.scrbl
View File

@ -8,6 +8,7 @@
browser/external
browser/tool
scheme/base
scheme/contract
scheme/class
scheme/gui/base
net/url
@ -26,8 +27,8 @@ The @schememodname[browser] library provides the following
procedures and classes for parsing and viewing HTML files. The
@schememodname[browser/htmltext] library provides a simplified
interface for rendering to a subclass of the MrEd @scheme[text%]
class. The [browser/external] library provides utilities for launching
an external browser (such as Firefox).
class. The @schememodname[browser/external] library provides utilities
for launching an external browser (such as Firefox).
@section[#:tag "browser"]{Browser}
@ -80,7 +81,7 @@ examples). The Scheme code is executed through @scheme[eval].
The @(litchar "MZSCHEME") forms are disabled unless the web page is a
@(litchar "file:") url that points into the @scheme[doc] collection.
@defproc[(open-url [url (or/c url? string? input-port?)]) void?]{
@defproc[(open-url [url (or/c url? string? input-port?)]) (is-a?/c hyper-frame%)]{
Opens the given url
in a vanilla browser frame and returns
the frame. The frame is an instance of
@ -534,7 +535,6 @@ library.}
Extends the given @scheme[text%] class with implementations of the
@scheme[html-text<%>] methods. Hyperlinks are attached to clickbacks
that use @net-send-url from @schememodname[net/sendurl].
}
}
@defproc[(render-html-to-text [in input-port?]

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

@ -220,14 +220,14 @@
(match v
[`(,name ,self-modidx ,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy
,prefix ,kernel-exclusion ,reprovide-kernel?
,prefix
,indirect-provides ,num-indirect-provides
,indirect-syntax-provides ,num-indirect-syntax-provides
,indirect-et-provides ,num-indirect-et-provides
,protects ,et-protects
,provide-phase-count . ,rest)
(let ([phase-data (take rest (* 8 provide-phase-count))])
(match (list-tail rest (* 8 provide-phase-count))
(let ([phase-data (take rest (* 9 provide-phase-count))])
(match (list-tail rest (* 9 provide-phase-count))
[`(,syntax-body ,body
,requires ,syntax-requires ,template-requires ,label-requires
,more-requires-count . ,more-requires)
@ -729,7 +729,7 @@
[read-accept-dot #t]
[read-accept-infix-dot #t]
[read-accept-quasiquote #t])
(read (open-input-bytes s))))]
(read/recursive (open-input-bytes s))))]
[(reference)
(make-primval (read-compact-number cp))]
[(small-list small-proper-list)
@ -837,7 +837,17 @@
[(box)
(box (read-compact cp))]
[(quote)
(make-reader-graph (read-compact cp))]
(make-reader-graph
;; Nested escapes need to share graph references. So get inside the
;; read where `read/recursive' can be used:
(let ([rt (current-readtable)])
(parameterize ([current-readtable (make-readtable
#f
#\x 'terminating-macro
(lambda args
(parameterize ([current-readtable rt])
(read-compact cp))))])
(read (open-input-bytes #"x")))))]
[(symref)
(let* ([l (read-compact-number cp)]
[v (vector-ref (cport-symtab cp) l)])

10
collects/drscheme/private/main.ss
View File

@ -226,6 +226,7 @@
null
list?)
(drscheme:font:setup-preferences)
(color-prefs:add-background-preferences-panel)
(scheme:add-preferences-panel)
@ -233,6 +234,7 @@
(preferences:add-editor-checkbox-panel)
(preferences:add-warnings-checkbox-panel)
(preferences:add-scheme-checkbox-panel)
(preferences:add-general-checkbox-panel)
(let ([make-check-box
(λ (pref-sym string parent)
@ -245,7 +247,7 @@
(send checkbox get-value))))])
(preferences:add-callback pref-sym (λ (p v) (send q set-value v)))
(send q set-value (preferences:get pref-sym))))])
(preferences:add-to-editor-checkbox-panel
(preferences:add-to-general-checkbox-panel
(λ (editor-panel)
(make-check-box 'drscheme:open-in-tabs
(string-constant open-files-in-tabs)
@ -264,7 +266,11 @@
(make-check-box 'drscheme:module-language-first-line-special?
(string-constant ml-always-show-#lang-line)
editor-panel)
editor-panel)))
(preferences:add-to-editor-checkbox-panel
(λ (editor-panel)
(void)
;; come back to this one.
#;

3
collects/drscheme/private/rep.ss
View File

@ -84,8 +84,7 @@ TODO
text:ports<%>
editor:file<%>
scheme:text<%>
color:text<%>
text:ports<%>)
color:text<%>)
reset-highlighting
highlight-errors
highlight-errors/exn

16
collects/framework/main.ss
View File

@ -198,6 +198,12 @@
@{Adds a preferences panel for configuring options related to
editing.})
(proc-doc/names
preferences:add-general-checkbox-panel
(-> void?)
()
@{Adds a catch-all preferences panel for options.})
(proc-doc/names
preferences:add-warnings-checkbox-panel
(-> void?)
@ -232,7 +238,15 @@
(((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
(proc)
@{Saves @scheme[proc] until the preferences panel is created, when it
is called with the Echeme preferences panel to add new children to
is called with the editor preferences panel to add new children to
the panel.})
(proc-doc/names
preferences:add-to-general-checkbox-panel
(((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
(proc)
@{Saves @scheme[proc] until the preferences panel is created, when it
is called with the general preferences panel to add new children to
the panel.})
(proc-doc/names

18
collects/framework/private/color.ss
View File

@ -260,7 +260,11 @@ added get-regions
(define/private (re-tokenize ls in in-start-pos enable-suspend)
(let-values ([(lexeme type data new-token-start new-token-end)
(get-token in)])
(begin
(enable-suspend #f)
(begin0
(get-token in)
(enable-suspend #t)))])
(unless (eq? 'eof type)
(enable-suspend #f)
#; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start))
@ -365,10 +369,14 @@ added get-regions
(for-each
(lambda (ls)
(re-tokenize ls
(open-input-text-editor this
(lexer-state-current-pos ls)
(lexer-state-end-pos ls)
(λ (x) #f))
(begin
(enable-suspend #f)
(begin0
(open-input-text-editor this
(lexer-state-current-pos ls)
(lexer-state-end-pos ls)
(λ (x) #f))
(enable-suspend #t)))
(lexer-state-current-pos ls)
enable-suspend))
lexer-states)))))

18
collects/framework/private/decorated-editor-snip.ss
View File

@ -22,6 +22,9 @@
(define editor-snip:decorated-mixin
(mixin ((class->interface editor-snip%)) (editor-snip:decorated<%>)
(init [with-border? #t])
(define draw-border? with-border?)
;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%))
;; returns the bitmap to be shown in the top right corner.
(define/public (get-corner-bitmap) #f)
@ -152,13 +155,14 @@
(+ x (unbox bil) 2)
(+ y (unbox bmt)))])))
(send dc set-pen (get-pen))
(send dc set-brush (get-brush))
(send dc draw-rectangle
(+ x (unbox bil))
(+ y (unbox bit))
(max 0 (- (unbox bw) (unbox bil) (unbox bir)))
(max 0 (- (unbox bh) (unbox bit) (unbox bib))))
(when draw-border?
(send dc set-pen (get-pen))
(send dc set-brush (get-brush))
(send dc draw-rectangle
(+ x (unbox bil))
(+ y (unbox bit))
(max 0 (- (unbox bw) (unbox bil) (unbox bir)))
(max 0 (- (unbox bh) (unbox bit) (unbox bib)))))
(send dc set-pen old-pen)
(send dc set-brush old-brush))))

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

@ -2096,17 +2096,14 @@
(send (send find-edit get-canvas) focus))))
(define/public (unhide-search-and-toggle-focus)
(cond
[hidden?
(unhide-search #t)]
[(or (not text-to-search)
(send (send text-to-search get-canvas) has-focus?))
(send find-edit set-position 0 (send find-edit last-position))
(send find-canvas focus)]
[else
(let ([canvas (send text-to-search get-canvas)])
(when canvas
(send canvas focus)))]))
(if hidden?
(unhide-search #t)
(let ([canvas (and text-to-search (send text-to-search get-canvas))])
(cond
[(or (not text-to-search) (and canvas (send canvas has-focus?)))
(send find-edit set-position 0 (send find-edit last-position))
(send find-canvas focus)]
[canvas (send canvas focus)]))))
(define/public (search searching-direction)
(unhide-search #f)

60
collects/framework/private/preferences.ss
View File

@ -227,8 +227,9 @@ the state transitions / contracts are:
(super show on?))
(super-new))]
[frame
(make-object frame-stashed-prefs%
(string-constant preferences))]
(new frame-stashed-prefs%
[label (string-constant preferences)]
[height 200])]
[build-ppanel-tree
(λ (ppanel tab-panel single-panel)
(send tab-panel append (ppanel-name ppanel))
@ -310,6 +311,11 @@ the state transitions / contracts are:
(let ([old editor-panel-procs])
(λ (parent) (old parent) (f parent)))))
(define (add-to-general-checkbox-panel f)
(set! general-panel-procs
(let ([old general-panel-procs])
(λ (parent) (old parent) (f parent)))))
(define (add-to-warnings-checkbox-panel f)
(set! warnings-panel-procs
(let ([old warnings-panel-procs])
@ -317,6 +323,7 @@ the state transitions / contracts are:
(define scheme-panel-procs void)
(define editor-panel-procs void)
(define general-panel-procs void)
(define warnings-panel-procs void)
(define (add-checkbox-panel label proc)
@ -394,21 +401,8 @@ the state transitions / contracts are:
(list (string-constant editor-prefs-panel-label)
(string-constant general-prefs-panel-label))
(λ (editor-panel)
(make-recent-items-slider editor-panel)
(make-check editor-panel
'framework:autosaving-on?
(string-constant auto-save-files)
values values)
(make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values)
(make-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace)
not not)
(make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values)
(make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values)
(make-check editor-panel
'framework:display-line-numbers
(string-constant display-line-numbers)
values values)
(make-check editor-panel
'framework:auto-set-wrap?
(string-constant wrap-words-in-editor-buffers)
@ -432,13 +426,7 @@ the state transitions / contracts are:
'framework:coloring-active
(string-constant online-coloring-active)
values values)
(unless (eq? (system-type) 'unix)
(make-check editor-panel
'framework:print-output-mode
(string-constant automatically-to-ps)
(λ (b)
(if b 'postscript 'standard))
(λ (n) (eq? 'postscript n))))
(make-check editor-panel
'framework:anchored-search
(string-constant find-anchor-based)
@ -454,6 +442,34 @@ the state transitions / contracts are:
(editor-panel-procs editor-panel))))])
(add-editor-checkbox-panel)))
(define (add-general-checkbox-panel)
(letrec ([add-general-checkbox-panel
(λ ()
(set! add-general-checkbox-panel void)
(add-checkbox-panel
(list (string-constant general-prefs-panel-label))
(λ (editor-panel)
(make-recent-items-slider editor-panel)
(make-check editor-panel
'framework:autosaving-on?
(string-constant auto-save-files)
values values)
(make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values)
(make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values)
(make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values)
(make-check editor-panel
'framework:display-line-numbers
(string-constant display-line-numbers)
values values)
(unless (eq? (system-type) 'unix)
(make-check editor-panel
'framework:print-output-mode
(string-constant automatically-to-ps)
(λ (b)
(if b 'postscript 'standard))
(λ (n) (eq? 'postscript n)))))))])
(add-general-checkbox-panel)))
(define (add-warnings-checkbox-panel)
(letrec ([add-warnings-checkbox-panel
(λ ()

2
collects/framework/private/sig.ss
View File

@ -74,10 +74,12 @@
add-font-panel
add-editor-checkbox-panel
add-general-checkbox-panel
add-warnings-checkbox-panel
add-scheme-checkbox-panel
add-to-editor-checkbox-panel
add-to-general-checkbox-panel
add-to-warnings-checkbox-panel
add-to-scheme-checkbox-panel

6
collects/framework/private/text.ss
View File

@ -1170,7 +1170,11 @@ WARNING: printf is rebound in the body of the unit to always
(set! clear-yellow void)
(when (and searching-str (= (string-length searching-str) (- end start)))
(when (do-search searching-str start end)
(set! clear-yellow (highlight-range start end "khaki" #f 'low 'ellipse))))
(set! clear-yellow (highlight-range start end
(if (preferences:get 'framework:white-on-black?)
(make-object color% 50 50 5)
"khaki")
#f 'low 'ellipse))))
(end-edit-sequence)]))]
[else
(clear-yellow)

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

@ -16,6 +16,7 @@
[advanced-define define]
[advanced-define-struct define-struct]
[advanced-lambda lambda]
[advanced-lambda λ]
[advanced-app #%app]
[beginner-top #%top]
[intermediate-local local]

1
collects/lang/htdp-intermediate-lambda.ss
View File

@ -12,6 +12,7 @@
[intermediate-lambda-define define]
[intermediate-define-struct define-struct]
[intermediate-lambda lambda]
[intermediate-lambda λ]
[advanced-app #%app]
[beginner-top #%top]
[intermediate-local local]

7
collects/mred/mred.ss
View File

@ -74,6 +74,11 @@
(namespace-require 'scheme/class))
ns))
(define (make-eventspace)
(parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)]
[wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)])
(wx:make-eventspace)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax propagate
@ -139,7 +144,6 @@
is-color-display?
key-event%
keymap%
make-eventspace
editor-admin%
editor-set-x-selection-mode
editor-snip-editor-admin<%>
@ -307,6 +311,7 @@
current-eventspace-has-standard-menus?
current-eventspace-has-menu-root?
eventspace-handler-thread
make-eventspace
make-gui-namespace
make-gui-empty-namespace
file-creator-and-type

2
collects/mred/private/wxme/cycle.ss
View File

@ -25,3 +25,5 @@
(decl editor-put-file set-editor-put-file!)
(decl popup-menu% set-popup-menu%!)

23
collects/mred/private/wxme/editor.ss
View File

@ -611,11 +611,8 @@
(and
;; Read headers
(for/and ([i (in-range num-headers)])
(let-boxes ([n 0]
[len 0])
(begin
(send f get n)
(send f get-fixed len))
(let ([n (send f get-exact)]
[len (send f get-fixed-exact)])
(and (send f ok?)
(or (zero? len)
(let ([sclass (send (send f get-s-scl) find-by-map-position f n)])
@ -646,11 +643,10 @@
(let ([sclass (if (n . >= . 0)
(send (send f get-s-scl) find-by-map-position f n)
#f)]) ; -1 => unknown
(let-boxes ([len 0])
(if (or (not sclass)
(not (send sclass get-s-required?)))
(send f get-fixed len)
(set-box! len -1))
(let ([len (if (or (not sclass)
(not (send sclass get-s-required?)))
(send f get-fixed-exact)
-1)])
(and (send f ok?)
(or (and (zero? len) accum)
(and
@ -658,8 +654,7 @@
(let ([start (send f tell)])
(when (len . >= . 0)
(send f set-boundary len))
(let-boxes ([style-index 0])
(send f get style-index)
(let ([style-index (send f get-exact)])
(let ([snip (send sclass read f)])
(and
snip
@ -1337,7 +1332,7 @@
(editor-get-file "choose a file" (extract-parent) #f path))
(def/public (put-file [(make-or-false path-string?) dir]
[(make-or-false string?) suggested-name])
[(make-or-false path-string?) suggested-name])
(editor-put-file "save file as" (extract-parent) dir suggested-name))
(def/public (set-load-overwrites-styles [any? b?])
@ -1419,7 +1414,7 @@
(let ([sclass (snip->snipclass snip)])
(unless sclass
(error 'write-snips-to-file "snip has no snipclass"))
(if (send f do-get-header-flag sclass)
(if (not (send f do-get-header-flag sclass))
(begin
(send f put (send f do-map-position sclass))
(let ([header-start (send f tell)])

2
collects/mred/private/wxme/pasteboard.ss
View File

@ -1913,7 +1913,7 @@
(do-write-headers-footers f #f)))
(def/override (read-from-file [editor-stream-in% f]
[bool? [overwritestyle? #t]])
[bool? [overwritestyle? #f]])
(if (or s-user-locked?
(not (zero? write-locked)))
#f

20
collects/mred/private/wxme/snip.ss
View File

@ -27,6 +27,11 @@
get-the-editor-data-class-list
the-editor-snip-class
the-snip-class-list ;; parameter
make-the-snip-class-list
the-editor-data-class-list ;; parameter
make-the-editor-data-class-list
(struct-out snip-class-link)
(struct-out editor-data-class-link)
@ -315,11 +320,9 @@
(s-read (make-object string-snip% 0) f))
(def/public (s-read [string-snip% snip] [editor-stream-in% f])
(let-boxes ([flags 0])
(send f get flags)
(let ([flags (send f get-exact)])
(let ([pos (send f tell)])
(let-boxes ([count 0])
(send f get count)
(let ([count (send f get-exact)])
(send f jump-to pos)
(let ([count (if (count . < . 0)
10; this is a failure; we make up something
@ -1323,9 +1326,10 @@
(define (make-the-snip-class-list)
(new standard-snip-class-list%))
(define the-snip-class-list (make-the-snip-class-list))
(define the-snip-class-list (make-parameter (make-the-snip-class-list)))
(define (get-the-snip-class-list)
the-snip-class-list)
(the-snip-class-list))
;; ------------------------------------------------------------
@ -1465,9 +1469,9 @@
(define (make-the-editor-data-class-list)
(new editor-data-class-list%))
(define the-editor-data-class-list (make-the-editor-data-class-list))
(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list)))
(define (get-the-editor-data-class-list)
the-editor-data-class-list)
(the-editor-data-class-list))
;; ------------------------------------------------------------

169
collects/mred/private/wxme/stream.ss
View File

@ -99,7 +99,11 @@
(def/public (read-bytes [bytes? v]
[exact-nonnegative-integer? [start 0]]
[exact-nonnegative-integer? [end (bytes-length v)]])
0))
0)
(def/public (read-byte)
(let ([s (make-bytes 1)])
(and (= 1 (read-bytes s 0 1))
(bytes-ref s 0)))))
(defclass editor-stream-out-base% object%
(super-new)
@ -116,6 +120,8 @@
;; ----------------------------------------
(define mz:read-byte read-byte)
(defclass editor-stream-in-port-base% editor-stream-in-base%
(init-field port)
(super-new)
@ -137,7 +143,11 @@
(let ([r (read-bytes! v port start end)])
(if (eof-object? r)
0
r))))
r)))
(def/override (read-byte)
(let ([v (mz:read-byte port)])
(if (eof-object? v) #f v))))
(defclass editor-stream-in-file-base% editor-stream-in-port-base%
(super-new))
@ -182,6 +192,8 @@
;; ----------------------------------------
(define in-read-byte (generic editor-stream-in-base% read-byte))
(defclass editor-stream-in% editor-stream%
(init-rest args)
@ -216,48 +228,50 @@
(define (bad!) (set! is-bad? #t) 0)
(if is-bad?
0
(let ([s (make-bytes 1)])
(let loop ([prev-byte 0])
(if (not (= 1 (send f read-bytes s)))
(let loop ([prev-byte 0])
(let ([b (send-generic f in-read-byte)])
(if (not b)
(bad!)
(let ([b (bytes-ref s 0)])
(case (integer->char b)
[(#\#)
(let ([pos (send f tell)])
(if (and (= 1 (send f read-bytes s))
(= (bytes-ref s 0) (char->integer #\|)))
;; skip to end of comment
(let cloop ([saw-bar? #f]
[saw-hash? #f]
[nesting 0])
(if (not (= 1 (send f read-bytes s)))
(case (integer->char b)
[(#\#)
(let ([pos (send f tell)]
[b (send-generic f in-read-byte)])
(if (and b
(= b (char->integer #\|)))
;; skip to end of comment
(let cloop ([saw-bar? #f]
[saw-hash? #f]
[nesting 0])
(let ([b (send-generic f in-read-byte)])
(if (not b)
(bad!)
(cond
[(and saw-bar? (= (bytes-ref s 0) (char->integer #\#)))
[(and saw-bar? (= b (char->integer #\#)))
(if (zero? nesting)
(loop (char->integer #\space))
(cloop #f #f (sub1 nesting)))]
[(and saw-hash? (= (bytes-ref s 0) (char->integer #\|)))
[(and saw-hash? (= b (char->integer #\|)))
(cloop #t #f (add1 nesting))]
[else (cloop (= (bytes-ref s 0) (char->integer #\|))
(= (bytes-ref s 0) (char->integer #\#))
nesting)])))
(begin
(send f seek pos)
(char->integer #\#))))]
[(#\;)
;; skip to end of comment
(let cloop ()
(if (not (= 1 (send f read-bytes s)))
[else (cloop (= b (char->integer #\|))
(= b (char->integer #\#))
nesting)]))))
(begin
(send f seek pos)
(char->integer #\#))))]
[(#\;)
;; skip to end of comment
(let cloop ()
(let ([b (send-generic f in-read-byte)])
(if (not b)
(bad!)
(if (or (= (bytes-ref s 0) (char->integer #\newline))
(= (bytes-ref s 0) (char->integer #\return)))
(if (or (= b (char->integer #\newline))
(= b (char->integer #\return)))
(loop (char->integer #\space))
(cloop))))]
[else
(if (char-whitespace? (integer->char b))
(loop b)
b)])))))))
(cloop)))))]
[else
(if (char-whitespace? (integer->char b))
(loop b)
b)]))))))
(define/private (skip-whitespace [buf #f])
(let ([c (do-skip-whitespace)])
@ -270,9 +284,8 @@
[(char-whitespace? (integer->char b)) #t]
[(= b (char->integer #\#))
(let ([pos (send f tell)]
[s (make-bytes 1)])
(send f read-bytes s)
(let ([d? (= (bytes-ref s 0) (char->integer #\|))])
[b (send-generic f in-read-byte)])
(let ([d? (= b (char->integer #\|))])
(send f seek (if d? (sub1 pos) pos))
d?))]
[(= b (char->integer #\;))
@ -284,36 +297,43 @@
(let ([c0 (skip-whitespace)])
(if (check-boundary)
(if get-exact? 0 0.0)
(let* ([s (make-bytes 1)]
[l (cons (integer->char c0)
(let loop ([counter 50])
(if (zero? counter)
null
(if (= 1 (send f read-bytes s))
(let ([s (bytes-ref s 0)])
(if (is-delim? s)
null
(cons (integer->char s)
(loop (sub1 counter)))))
null))))])
(let* ([l
;; As fast path, accum integer result
(let loop ([counter 50][c c0][v 0])
(if (zero? counter)
null
(if (or (not c)
(is-delim? c))
(or v null)
(let ([rest (loop (sub1 counter)
(send-generic f in-read-byte)
(and v
(c . >= . (char->integer #\0))
(c . <= . (char->integer #\9))
(+ (* v 10) (- c (char->integer #\0)))))])
(if (exact-integer? rest)
rest
(cons (integer->char c) rest))))))])
(inc-item-count)
(let ([n (string->number (list->string l))])
(let ([n (if (exact-integer? l)
l
(string->number (list->string l)))])
(cond
[(or (not n)
(not (real? n))
(and get-exact? (not (exact-integer? n))))
(set! is-bad? #t)
(if get-exact? 0 0.0)]
[get-exact? n]
[(and get-exact? (exact-integer? n)) n]
[(real? n) (exact->inexact n)]
[else
(exact->inexact n)]))))))
(set! is-bad? #t)
(if get-exact? 0 0.0)]))))))
(define/private (get-a-string limit recur?)
(let* ([orig-len (if recur?
(if (limit . < . 16)
limit
16)
(get-exact))]
(let ([v (get-exact)])
(if (check-boundary)
0
v)))]
[buf (make-bytes 32)]
[fail (lambda ()
(set! is-bad? #t)
@ -447,20 +467,22 @@
(success)
(loop))))]))))
(def/public (get-fixed-exact)
(if (check-boundary)
0
(if (read-version . < . 8)
(let ([buf (make-bytes 4)])
(send f read-bytes buf)
(integer-bytes->integer
buf
#t
(if (= read-version 1)
(system-big-endian?)
#t)))
(get-exact))))
(def/public (get-fixed [box? vb])
(let ([v (if (check-boundary)
0
(if (read-version . < . 8)
(let ([buf (make-bytes 4)])
(send f read-bytes buf)
(integer-bytes->integer
buf
#t
(if (= read-version 1)
(system-big-endian?)
#t)))
(get-exact)))])
(set-box! vb v)))
(set-box! vb (get-fixed-exact)))
#|
integer format specified by first byte:
@ -569,7 +591,7 @@
#t
(cond
[(and (pair? boundaries)
(items . > . (car boundaries)))
(items . >= . (car boundaries)))
(set! is-bad? #t)
(error 'editor-stream-in%
"overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))]
@ -647,6 +669,7 @@
(bytes-append spc
(make-bytes (- 11 (string-length s)) (char->integer #\space))
(string->bytes/latin-1 s))))
(set! col new-col)
(set! items (add1 items)))
this)

160
collects/mred/private/wxme/text.ss
View File

@ -384,7 +384,7 @@
(not (zero? how-close))
((abs how-close) . > . between-threshold))])
(let ([snip (and onit?
(find-snip pos 'after))])
(do-find-snip pos 'after))])
(and snip
(let-boxes ([x 0.0] [y 0.0])
(get-snip-position-and-location snip #f x y)
@ -428,7 +428,7 @@
((abs how-close) . > . between-threshold))])
(if onit?
;; we're in the snip's horizontal region...
(let ([snip (find-snip now 'after)])
(let ([snip (do-find-snip now 'after)])
;; ... but maybe the mouse is above or below it.
(let-boxes ([top 0.0]
[bottom 0.0]
@ -1332,7 +1332,7 @@
(let* ([gsnip (if (not did-one?)
(begin
(make-snipset start start)
(find-snip start 'after-or-none))
(do-find-snip start 'after-or-none))
before-snip)]
[before-snip (or before-snip gsnip)]
[inserted-new-line?
@ -1534,7 +1534,7 @@
[(or (equal? c #\newline) (equal? c #\tab))
(let ([newline? (equal? c #\newline)])
(make-snipset (+ i start) (+ i start 1))
(let ([snip (find-snip (+ i start) 'after)])
(let ([snip (do-find-snip (+ i start) 'after)])
(if newline?
;; forced return - split the snip
@ -1611,7 +1611,7 @@
(when (eq? (mline-last-snip (snip->line snip)) snip)
(set-mline-last-snip! (snip->line tabsnip) tabsnip))))))
(let ([snip (find-snip (+ i start 1) 'after)])
(let ([snip (do-find-snip (+ i start 1) 'after)])
(let ([i (add1 i)])
(loop (+ i start)
(if (= i addlen) #f (string-snip-buffer snip))
@ -1623,7 +1623,7 @@
[(cnt . > . MAX-COUNT-FOR-SNIP)
;; divide up snip, because it's too large:
(make-snipset (+ i start) (+ i start))
(let ([snip (find-snip (+ i start) 'after)])
(let ([snip (do-find-snip (+ i start) 'after)])
(loop (+ i start)
(string-snip-buffer snip)
(add1 (string-snip-dtext snip))
@ -1711,8 +1711,8 @@
(make-snipset start end)
(set! revision-count (add1 revision-count))
(let* ([start-snip (find-snip start 'before-or-none)]
[end-snip (find-snip end 'before)]
(let* ([start-snip (do-find-snip start 'before-or-none)]
[end-snip (do-find-snip end 'before)]
[with-undo? (and with-undo?
(zero? s-noundomode))]
[rec (if with-undo?
@ -1956,8 +1956,8 @@
s-style-list)])
(set-common-copy-region-data! (get-region-data startp endp))
(let ([start (find-snip startp 'after)]
[end (find-snip endp 'after-or-none)]
(let ([start (do-find-snip startp 'after)]
[end (do-find-snip endp 'after-or-none)]
[wl? write-locked?]
[fl? flow-locked?])
@ -2050,7 +2050,7 @@
(let ([addpos (snip->count snip)])
(insert snip read-insert)
(when data
(let ([snip (find-snip read-insert 'after)])
(let ([snip (do-find-snip read-insert 'after)])
(set-snip-data snip data)))
(set! read-insert (+ read-insert addpos))))
@ -2300,8 +2300,8 @@
((clickback-end c) . > . start)
;; we're in the right horizontal region, but maybe the mouse
;; is above or below the clickback
(let ([start (find-snip (clickback-start c) 'after)]
[end (find-snip (clickback-end c) 'before)])
(let ([start (do-find-snip (clickback-start c) 'after)]
[end (do-find-snip (clickback-end c) 'before)])
(and start
end
(let-boxes ([top 0.0]
@ -2510,18 +2510,20 @@
(send s-style-list new-named-style "Standard" (send s-style-list basic-style))
(send mf ok?))))))]
[(or (eq? format 'text) (eq? format 'text-force-cr))
(let loop ([saved-cr? #f])
(let ([l (read-string 256 f)])
(unless (eof-object? l)
(let ([l2 (if (equal? l "")
l
(if (equal? #\return (string-ref l (sub1 (string-length l))))
(substring l 0 (sub1 (string-length l)))
l))])
(insert (regexp-replace* #rx"\r\n"
(if saved-cr? (string-append "\r" l2) l2)
"\n"))
(loop (not (eq? l l2)))))))
(let ([s (make-string 1024)])
(let loop ([saved-cr? #f])
(let ([len (read-string! s f)])
(unless (eof-object? len)
(let* ([s1 (if (= len (string-length s))
s
(substring s 0 len))]
[s2 (if (equal? #\return (string-ref s1 (sub1 len)))
(substring s1 0 (sub1 len))
s1)])
(insert (regexp-replace* #rx"\r\n"
(if saved-cr? (string-append "\r" s2) s2)
"\n"))
(loop (not (eq? s1 s2))))))))
#f])])
(when fileerr?
@ -2559,7 +2561,6 @@
(error (method-name 'text% 'save-port) "error writing editor content"))
#t)))
(define/private (do-read-from-file f start overwritestyle?)
(if write-locked?
#f
@ -2579,9 +2580,9 @@
(define/override (read-from-file . args)
(case-args
args
[([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #t]])
[([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #f]])
(do-read-from-file f start overwritestyle?)]
[([editor-stream-in% f] [any? [overwritestyle? #t]])
[([editor-stream-in% f] [any? [overwritestyle? #f]])
(do-read-from-file f 'start overwritestyle?)]
(method-name 'text% 'read-from-file)))
@ -2605,8 +2606,8 @@
len
end)
start)])
(let ([start-snip (if (zero? len) #f (find-snip start 'after))]
[end-snip (if (zero? len) #f (find-snip end 'after-or-none))])
(let ([start-snip (if (zero? len) #f (do-find-snip start 'after))]
[end-snip (if (zero? len) #f (do-find-snip end 'after-or-none))])
(and (do-write-headers-footers f #t)
(write-snips-to-file f s-style-list #f start-snip end-snip #f this)
(do-write-headers-footers f #f))))))
@ -3524,7 +3525,7 @@
(cond
[new-style new-style]
[caret-style (send s-style-list find-or-create-style caret-style delta)]
[else (let ([gsnip (find-snip start 'before)])
[else (let ([gsnip (do-find-snip start 'before)])
(send s-style-list find-or-create-style (snip->style gsnip) delta))])))]
[else
(set! write-locked? #t)
@ -3544,7 +3545,7 @@
(begin
(set! initial-style-needed? #f)
(values snips #f))
(values (find-snip start 'after) (find-snip end 'after-or-none)))]
(values (do-find-snip start 'after) (do-find-snip end 'after-or-none)))]
[(rec)
(and (zero? s-noundomode)
(make-object style-change-record% start end
@ -4007,8 +4008,6 @@
(set! write-locked? #t)
(set! flow-locked? #t)
(set-box! a-ptr #f)
(set-box! b-ptr #f)
(send snip split pos a-ptr b-ptr)
(set! read-locked? #f)
@ -4071,7 +4070,8 @@
(splice-snip snip prev next)
(set! snip-count (add1 snip-count))
(insert-snip snip ins-snip)
(extra snip)
(when extra
(extra snip))
(snip-set-admin snip snip-admin)
(snip-set-admin ins-snip snip-admin)
@ -4084,11 +4084,11 @@
(let-values ([(snip s-pos) (find-snip/pos start 'after-or-none)])
(when snip
(unless (= s-pos start)
(split-one start s-pos snip void)))))
(split-one start s-pos snip #f)))))
(when (positive? end)
(let-values ([(snip s-pos) (find-snip/pos end 'before)])
(unless (= (+ s-pos (snip->count snip)) end)
(split-one end s-pos snip void)))))
(split-one end s-pos snip #f)))))
(define/private (insert-text-snip start style)
(let* ([snip (on-new-string-snip)]
@ -4257,6 +4257,11 @@
#f
snips))
(define/private (do-find-snip p direction)
;; BEWARE: `len' may not be up-to-date
(let-values ([(snip pos) (find-snip/pos p direction)])
snip))
(def/public (find-snip [exact-nonnegative-integer? p]
[(symbol-in before-or-none before after after-or-none) direction]
[maybe-box? [s-pos #f]])
@ -4270,48 +4275,49 @@
(cond
[(and (eq? direction 'before-or-none) (zero? p))
(values #f 0)]
[(and (eq? direction 'after-or-none) (p . >= . (let ([l (mline-last (unbox line-root-box))])
(+ (mline-get-position l)
(mline-len l)))))
(values #f 0)]
[else
(let* ([line (mline-find-position (unbox line-root-box) p)]
[pos (mline-get-position line)]
[p (- p pos)])
(if (and (eq? direction 'after-or-none)
(not (mline-next line))
(p . >= . (mline-len line)))
;; past the end:
(values #f 0)
;; within the line:
(let-values ([(snip pos p)
(let ([snip (mline-snip line)])
(if (and (zero? p) (snip->prev snip))
;; back up one:
(let ([snip (snip->prev snip)])
(values snip
(- pos (snip->count snip))
(+ p (snip->count snip))))
(values snip pos p)))])
(let-values ([(snip pos p)
(let ([snip (mline-snip line)])
(if (and (zero? p) (snip->prev snip))
;; back up one:
(let ([snip (snip->prev snip)])
(values snip
(- pos (snip->count snip))
(+ p (snip->count snip))))
(values snip pos p)))])
(let loop ([snip snip]
[pos pos]
[p p])
(if snip
(let ([p (- p (snip->count snip))])
(cond
[(or (and (eq? direction 'on)
(zero? p))
(and (or (eq? direction 'before)
(eq? direction 'before-or-none))
(p . <= . 0))
(and (or (eq? direction 'after)
(eq? direction 'after-or-none))
(p . < . 0)))
(values snip pos)]
[(and (eq? direction 'on)
(p . < . 0))
(values #f 0)]
[else
(loop (snip->next snip) (+ pos (snip->count snip)) p)]))
(if (not (eq? direction 'after-or-none))
(values last-snip (- pos (snip->count last-snip)))
(values #f 0))))))]))
(let loop ([snip snip]
[pos pos]
[p p])
(if snip
(let ([p (- p (snip->count snip))])
(cond
[(or (and (eq? direction 'on)
(zero? p))
(and (or (eq? direction 'before)
(eq? direction 'before-or-none))
(p . <= . 0))
(and (or (eq? direction 'after)
(eq? direction 'after-or-none))
(p . < . 0)))
(values snip pos)]
[(and (eq? direction 'on)
(p . < . 0))
(values #f 0)]
[else
(loop (snip->next snip) (+ pos (snip->count snip)) p)]))
(if (not (eq? direction 'after-or-none))
(values last-snip (- pos (snip->count last-snip)))
(values #f 0)))))))]))
(def/public (find-next-non-string-snip [(make-or-false snip%) snip])
(if (or (and snip
@ -4715,9 +4721,9 @@
(cond
[(not (= delayedscroll -1))
(scroll-to-position/refresh delayedscroll delayedscrollateol? #f
delayedscrollend delayedscrollbias)
(set! refresh-all? #t)]
(when (scroll-to-position/refresh delayedscroll delayedscrollateol? #f
delayedscrollend delayedscrollbias)
(set! refresh-all? #t))]
[delayedscrollbox?
(set! delayedscrollbox? #f)
(when (do-scroll-to delayedscrollsnip delayedscroll-x delayedscroll-y

3
collects/mred/private/wxme/undo.ss
View File

@ -4,7 +4,8 @@
"snip.ss"
"snip-flags.ss")
(provide proc-record%
(provide change-record%
proc-record%
unmodify-record%
insert-record%
insert-snip-record%

5
collects/r6rs/scribblings/r6rs.scrbl
View File

@ -360,6 +360,11 @@ several known ways:
instead of @|r6rs| bindings. In particular, @scheme[=>], @scheme[else],
@scheme[_], and @scheme[...] are not bound.}
@item{Bindings for @schemeidfont{#%datum}, @schemeidfont{#%app},
@schemeidfont{#%top}, and @schemeidfont{#%top-interaction} are
imported into every library and program, and at every phase
level for which the library or program has imports.}
]

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

@ -1843,6 +1843,8 @@
(values (apply-reduction-relation red arg) #f))
(define (test-->>/procs red arg expected apply-red cycles-ok? srcinfo)
(unless (reduction-relation? red)
(error 'test--> "expected a reduction relation as first argument, got ~e" red))
(let-values ([(got got-cycle?) (apply-red red arg)])
(inc-tests)

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

@ -347,6 +347,10 @@
(test (generate-term lang (side-condition a (odd? (term a))) 5) 43)
(test (raised-exn-msg exn:fail:redex? (generate-term lang c 5))
#rx"unable to generate")
(test (let/ec k
(generate-term lang (number_1 (side-condition any (k (term number_1)))) 5))
'number_1)
(test ; mismatch patterns work with side-condition failure/retry
(generate-term/decisions
lang e 5 0
@ -840,6 +844,89 @@
(check-metafunction n (λ (_) #t) #:retries 42))
#rx"check-metafunction: unable .* in 42"))
;; custom generators
(let ()
(define-language L
(x variable))
(test
(generate-term
L x_1 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['x (values 'x env)]
[_ (def acc)])))
'x)
(test
(let/ec k
(equal?
(generate-term
L (x x) 0
#:custom (let ([once? #f])
(λ (pat sz i-h acc env att rec def)
(match pat
['x (if once?
(k #f)
(begin
(set! once? #t)
(values 'x env)))]
[_ (def acc)]))))
'(x x)))
#t)
(test
(hash-ref
(let/ec k
(generate-term
L (x (x)) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
[(struct binder ('x))
(values 'y (hash-set env pat 'y))]
[(list (struct binder ('x))) (k env)]
[_ (def acc)]))))
(make-binder 'x))
'y)
(test
(generate-term
L (in-hole hole 7) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
[`(in-hole hole 7)
(rec 'hole #:contractum 7)]
[_ (def acc)])))
7)
(test
(let/ec k
(generate-term
L any 10
#:attempt 42
#:custom (λ (pat sz i-h acc env att rec def) (k (list sz att)))))
'(10 42))
(test
(let/ec k
(generate-term
L x 10
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['x (rec 7 #:size 0)]
[7 (k sz)]
[_ (def att)]))))
0)
(test
(generate-term
L (q 7) 0
#:custom (λ (pat sz i-h acc env att rec def)
(match pat
['q (rec '(7 7) #:acc 8)]
[7 (values (or acc 7) env)]
[_ (def att)])))
'((8 8) 7)))
;; parse/unparse-pattern
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])
(define-language lang (x variable))

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

@ -178,12 +178,12 @@
[parsed (parse-language lang)])
(make-rg-lang parsed lits (unique-chars lits) (find-base-cases parsed))))
(define (generate lang decisions@ retries what)
(define (generate lang decisions@ user-gen retries what)
(define-values/invoke-unit decisions@
(import) (export decisions^))
(define ((generate-nt lang base-cases generate pref-prods)
name cross? size attempt in-hole state)
name cross? size attempt in-hole env)
(let*-values
([(term _)
(generate/pred
@ -195,14 +195,12 @@
((if cross? base-cases-cross base-cases-non-cross)
base-cases))
((next-non-terminal-decision) name cross? lang attempt pref-prods)))])
(generate (max 0 (sub1 size)) attempt
(make-state #hash())
in-hole (rhs-pattern rhs))))
(generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs))))
(λ (_ env) (mismatches-satisfied? env))
size attempt)])
term))
(define (generate-sequence ellipsis generate state length)
(define (generate-sequence ellipsis generate env length)
(define (split-environment env)
(foldl (λ (var seq-envs)
(let ([vals (hash-ref env var #f)])
@ -213,17 +211,17 @@
(define (merge-environments seq-envs)
(foldl (λ (var env)
(hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs)))
(state-env state) (ellipsis-vars ellipsis)))
env (ellipsis-vars ellipsis)))
(let-values
([(seq envs)
(let recur ([envs (split-environment (state-env state))])
(let recur ([envs (split-environment env)])
(if (null? envs)
(values null null)
(let*-values
([(term state) (generate (make-state (car envs)) the-hole (ellipsis-pattern ellipsis))]
([(term env) (generate (car envs) the-hole (ellipsis-pattern ellipsis))]
[(terms envs) (recur (cdr envs))])
(values (cons term terms) (cons (state-env state) envs)))))])
(values seq (make-state (merge-environments envs)))))
(values (cons term terms) (cons env envs)))))])
(values seq (merge-environments envs))))
(define (generate/pred name gen pred init-sz init-att)
(let ([pre-threshold-incr
@ -244,9 +242,9 @@
name
retries
(if (= retries 1) "" "s"))
(let-values ([(term state) (gen size attempt)])
(if (pred term (state-env state))
(values term state)
(let-values ([(term env) (gen size attempt)])
(if (pred term env)
(values term env)
(retry (sub1 remaining)
(if (incr-size? remaining) (add1 size) size)
(+ attempt
@ -254,13 +252,13 @@
post-threshold-incr
pre-threshold-incr)))))))))
(define (generate/prior name state generate)
(define (generate/prior name env generate)
(let* ([none (gensym)]
[prior (hash-ref (state-env state) name none)])
[prior (hash-ref env name none)])
(if (eq? prior none)
(let-values ([(term state) (generate)])
(values term (set-env state name term)))
(values prior state))))
(let-values ([(term env) (generate)])
(values term (hash-set env name term)))
(values prior env))))
(define (mismatches-satisfied? env)
(let ([groups (make-hasheq)])
@ -276,10 +274,7 @@
(and (not (hash-ref prior val #f))
(hash-set! prior val #t)))))))
(define-struct state (env))
(define new-state (make-state #hash()))
(define (set-env state name value)
(make-state (hash-set (state-env state) name value)))
(define empty-env #hash())
(define (bindings env)
(make-bindings
@ -288,111 +283,139 @@
(cons (make-bind (binder-name key) val) bindings)
bindings))))
(define (generate-pat lang sexp pref-prods size attempt state in-hole pat)
(define recur (curry generate-pat lang sexp pref-prods size attempt))
(define recur/pat (recur state in-hole))
(define (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)
(define recur (curry generate-pat lang sexp pref-prods user-gen user-acc size attempt))
(define recur/pat (recur env in-hole))
(define ((recur/pat/size-attempt pat) size attempt)
(generate-pat lang sexp pref-prods size attempt state in-hole pat))
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat))
(define clang (rg-lang-clang lang))
(define gen-nt
(generate-nt
clang
(rg-lang-base-cases lang)
(curry generate-pat lang sexp pref-prods)
(curry generate-pat lang sexp pref-prods user-gen user-acc)
pref-prods))
(match pat
[`number (values ((next-number-decision) attempt) state)]
[`natural (values ((next-natural-decision) attempt) state)]
[`integer (values ((next-integer-decision) attempt) state)]
[`real (values ((next-real-decision) attempt) state)]
[`(variable-except ,vars ...)
(generate/pred 'variable
(recur/pat/size-attempt 'variable)
(λ (var _) (not (memq var vars)))
size attempt)]
[`variable
(values ((next-variable-decision)
(rg-lang-chars lang) (rg-lang-lits lang) attempt)
state)]
[`variable-not-otherwise-mentioned
(generate/pred 'variable
(recur/pat/size-attempt 'variable)
(λ (var _) (not (memq var (compiled-lang-literals clang))))
size attempt)]
[`(variable-prefix ,prefix)
(define (symbol-append prefix suffix)
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
(let-values ([(term state) (recur/pat 'variable)])
(values (symbol-append prefix term) state))]
[`string
(values ((next-string-decision) (rg-lang-chars lang) (rg-lang-lits lang) attempt)
state)]
[`(side-condition ,pat ,(? procedure? condition))
(generate/pred (unparse-pattern pat)
(recur/pat/size-attempt pat)
(λ (_ env) (condition (bindings env)))
size attempt)]
[`(name ,(? symbol? id) ,p)
(let-values ([(term state) (recur/pat p)])
(values term (set-env state (make-binder id) term)))]
[`hole (values in-hole state)]
[`(in-hole ,context ,contractum)
(let-values ([(term state) (recur/pat contractum)])
(recur state term context))]
[`(hide-hole ,pattern) (recur state the-hole pattern)]
[`any
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
; Don't use preferred productions for the sexp language.
[(pref-prods) (if (eq? new-lang lang) pref-prods #f)]
[(term _) (generate-pat new-lang sexp pref-prods size attempt new-state the-hole nt)])
(values term state))]
[(? (is-nt? clang))
(values (gen-nt pat #f size attempt in-hole state) state)]
[(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))))
(generate/prior pat state (λ () (values (gen-nt nt #f size attempt in-hole state) state)))]
[(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b)))))
(generate/prior pat state (λ () (recur/pat b)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt)))))
(let ([term (gen-nt nt #f size attempt in-hole state)])
(values term (set-env state pat term)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b)))))
(let-values ([(term state) (recur/pat b)])
(values term (set-env state pat term)))]
[`(cross ,(? symbol? cross-nt))
(values (gen-nt cross-nt #t size attempt in-hole state) state)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)]
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)])
(if prior prior ((next-sequence-decision) attempt)))]
[(seq state) (generate-sequence ellipsis recur state length)]
[(rest state) (recur (set-env (set-env state class length) name length)
(define (default-gen user-acc)
(match pat
[`number (values ((next-number-decision) attempt) env)]
[`natural (values ((next-natural-decision) attempt) env)]
[`integer (values ((next-integer-decision) attempt) env)]
[`real (values ((next-real-decision) attempt) env)]
[`(variable-except ,vars ...)
(generate/pred 'variable
(recur/pat/size-attempt 'variable)
(λ (var _) (not (memq var vars)))
size attempt)]
[`variable
(values ((next-variable-decision)
(rg-lang-chars lang) (rg-lang-lits lang) attempt)
env)]
[`variable-not-otherwise-mentioned
(generate/pred 'variable
(recur/pat/size-attempt 'variable)
(λ (var _) (not (memq var (compiled-lang-literals clang))))
size attempt)]
[`(variable-prefix ,prefix)
(define (symbol-append prefix suffix)
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
(let-values ([(term env) (recur/pat 'variable)])
(values (symbol-append prefix term) env))]
[`string
(values ((next-string-decision) (rg-lang-chars lang) (rg-lang-lits lang) attempt)
env)]
[`(side-condition ,pat ,(? procedure? condition))
(generate/pred (unparse-pattern pat)
(recur/pat/size-attempt pat)
(λ (_ env) (condition (bindings env)))
size attempt)]
[`(name ,(? symbol? id) ,p)
(let-values ([(term env) (recur/pat p)])
(values term (hash-set env (make-binder id) term)))]
[`hole (values in-hole env)]
[`(in-hole ,context ,contractum)
(let-values ([(term env) (recur/pat contractum)])
(recur env term context))]
[`(hide-hole ,pattern) (recur env the-hole pattern)]
[`any
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
; Don't use preferred productions for the sexp language.
[(pref-prods) (if (eq? new-lang lang) pref-prods #f)]
[(term _) (generate-pat new-lang
sexp
pref-prods
user-gen
user-acc
size
attempt
empty-env
the-hole
nt)])
(values term env))]
[(? (is-nt? clang))
(values (gen-nt pat #f size attempt in-hole env) env)]
[(struct binder ((or (? (is-nt? clang) nt)
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
(generate/prior pat env (λ () (recur/pat nt)))]
[(struct binder ((or (? built-in? b)
(app (symbol-match named-nt-rx) (? built-in? b)))))
(generate/prior pat env (λ () (recur/pat b)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(? symbol? (? (is-nt? clang) nt)))))
(let-values ([(term _) (recur/pat nt)])
(values term (hash-set env pat term)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
(? symbol? (? built-in? b)))))
(let-values ([(term _) (recur/pat b)])
(values term (hash-set env pat term)))]
[`(cross ,(? symbol? cross-nt))
(values (gen-nt cross-nt #t size attempt in-hole env) env)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let*-values ([(length) (let ([prior (hash-ref env class #f)])
(if prior prior ((next-sequence-decision) attempt)))]
[(seq env) (generate-sequence ellipsis recur env length)]
[(rest env) (recur (hash-set (hash-set env class length) name length)
in-hole rest)])
(values (append seq rest) state))]
[(list-rest pat rest)
(let*-values
([(pat-term state) (recur/pat pat)]
[(rest-term state) (recur state in-hole rest)])
(values (cons pat-term rest-term) state))]
[else
(error what "unknown pattern ~s\n" pat)]))
(values (append seq rest) env))]
[(list-rest pat rest)
(let*-values
([(pat-term env) (recur/pat pat)]
[(rest-term env) (recur env in-hole rest)])
(values (cons pat-term rest-term) env))]
[else
(error what "unknown pattern ~s\n" pat)]))
(user-gen
pat size in-hole user-acc env attempt
(λ (pat #:size [size size] #:contractum [in-hole in-hole] #:acc [user-acc user-acc] #:env [env env])
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat))
default-gen))
(let ([rg-lang (prepare-lang lang)]
[rg-sexp (prepare-lang sexp)])
(λ (pat)
(let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))])
(λ (size attempt)
(let-values ([(term state)
(let-values ([(term env)
(generate/pred
pat
(λ (size attempt)
(generate-pat
rg-lang rg-sexp ((next-pref-prods-decision) (rg-lang-clang rg-lang))
size attempt new-state the-hole parsed))
rg-lang
rg-sexp
((next-pref-prods-decision) (rg-lang-clang rg-lang))
user-gen
#f
size
attempt
empty-env
the-hole
parsed))
(λ (_ env) (mismatches-satisfied? env))
size attempt)])
(values term (bindings (state-env state)))))))))
(values term (bindings env))))))))
(define-struct base-cases (cross non-cross))
@ -658,22 +681,31 @@
(unless (reduction-relation? x)
(raise-type-error 'redex-check "reduction-relation" x)))
(define-for-syntax (term-generator lang pat decisions@ retries what)
(define (defer-all pat size in-hole acc env att recur defer)
(defer acc))
(define-for-syntax (term-generator lang pat decisions@ custom retries what)
(with-syntax ([pattern
(rewrite-side-conditions/check-errs
(language-id-nts lang what)
what #t pat)])
#`((generate #,lang #,decisions@ #,retries '#,what) `pattern)))
#`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern)))
(define-syntax (generate-term stx)
(syntax-case stx ()
[(_ lang pat size . kw-args)
(with-syntax ([(attempt retries)
(with-syntax ([(attempt retries custom)
(parse-kw-args `((#:attempt . 1)
(#:retries . ,#'default-retries))
(#:retries . ,#'default-retries)
(#:custom . ,#'defer-all))
(syntax kw-args)
stx)])
(with-syntax ([generate (term-generator #'lang #'pat #'(generation-decisions) #'retries 'generate-term)])
(with-syntax ([generate (term-generator #'lang
#'pat
#'(generation-decisions)
#'custom
#'retries
'generate-term)])
(syntax/loc stx
(let-values ([(term _) (generate size attempt)])
term))))]
@ -702,25 +734,35 @@
(let-values ([(names names/ellipses)
(extract-names (language-id-nts #'lang 'redex-check)
'redex-check #t #'pat)]
[(attempts-stx source-stx retries-stx)
[(attempts-stx source-stx retries-stx custom-stx)
(apply values
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:source . #f)
(#:retries . ,#'default-retries))
(#:retries . ,#'default-retries)
(#:custom . ,#'defer-all))
(syntax kw-args)
stx))])
(with-syntax ([(name ...) names]
[(name/ellipses ...) names/ellipses]
[attempts attempts-stx]
[retries retries-stx]
[show (show-message stx)])
(with-syntax ([property (syntax
(λ (_ bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
property)))])
(quasisyntax/loc stx
(let ([att attempts]
[ret retries])
(let ([att #,attempts-stx]
[ret #,retries-stx]
[custom (contract
(-> any/c natural-number/c any/c any/c hash? natural-number/c
(->* (any/c)
(#:size natural-number/c
#:contractum any/c
#:acc any/c
#:env hash?)
(values any/c hash?))
(-> any/c (values any/c hash?))
(values any/c hash?))
#,custom-stx '+ '-)])
(assert-nat 'redex-check att)
(assert-nat 'redex-check ret)
(unsyntax
@ -740,13 +782,20 @@
(reduction-relation-srcs r)
(reduction-relation-lang r)))])])
(check-prop-srcs
lang pats srcs property random-decisions@ (max 1 (floor (/ att (length pats)))) ret
lang
pats
srcs
property
random-decisions@
custom
(max 1 (floor (/ att (length pats))))
ret
'redex-check
show
(test-match lang pat)
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat))))
#`(check-prop
#,(term-generator #'lang #'pat #'random-decisions@ #'ret 'redex-check)
#,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check)
property att show)))
(void))))))]))
@ -793,9 +842,10 @@
[(_ name . kw-args)
(identifier? #'name)
(with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries)
[(attempts retries custom)
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:retries . ,#'default-retries))
(#:retries . ,#'default-retries)
(#:custom . ,#'defer-all))
(syntax kw-args)
stx)]
[show (show-message stx)])
@ -806,7 +856,7 @@
[att attempts])
(assert-nat 'check-metafunction-contract att)
(check-prop
((generate lang decisions@ retries 'check-metafunction-contract)
((generate lang decisions@ custom retries 'check-metafunction-contract)
(if dom dom '(any (... ...))))
(λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)])
@ -814,10 +864,10 @@
att
show))))]))
(define (check-prop-srcs lang pats srcs prop decisions@ attempts retries what show
(define (check-prop-srcs lang pats srcs prop decisions@ custom attempts retries what show
[match #f]
[match-fail #f])
(let ([lang-gen (generate lang decisions@ retries what)])
(let ([lang-gen (generate lang decisions@ custom retries what)])
(when (for/and ([pat pats] [src srcs])
(check
(lang-gen pat)
@ -839,9 +889,10 @@
(syntax-case stx ()
[(_ name property . kw-args)
(with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries)
[(attempts retries custom)
(parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries))
(#:retries . ,#'default-retries)
(#:custm . ,#'defer-all))
(syntax kw-args)
stx)]
[show (show-message stx)])
@ -855,6 +906,7 @@
(metafunc-srcs m)
(λ (term _) (property term))
(generation-decisions)
custom
att
ret
'check-metafunction
@ -867,10 +919,11 @@
(define-syntax (check-reduction-relation stx)
(syntax-case stx ()
[(_ relation property . kw-args)
(with-syntax ([(attempts retries decisions@)
(with-syntax ([(attempts retries decisions@ custom)
(parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries)
(#:decisions . ,#'random-decisions@))
(#:decisions . ,#'random-decisions@)
(#:custom . ,#'defer-all))
(syntax kw-args)
stx)]
[show (show-message stx)])
@ -886,6 +939,7 @@
(reduction-relation-srcs rel)
(λ (term _) (property term))
decisions@
custom
attempts
retries
'check-reduction-relation

2
collects/redex/redex.scrbl
View File

@ -857,7 +857,7 @@ terminate (it does terminate if the only infinite reduction paths are cyclic).
error elsewhere. }
@defidform[fresh]{ Recognized specially within
@scheme[reduction-relation]. A @scheme[-->] form is an
@scheme[reduction-relation]. A @scheme[fresh] form is an
error elsewhere. }
@defidform[with]{ Recognized specially within

4
collects/scheme/dict.ss
View File

@ -150,7 +150,7 @@
[(dict-struct? d)
((get-dict-ref (dict-struct-ref d)) d key)]
[else
(raise-type-error 'dict-ref 'dict 0 d key)])]
(raise-type-error 'dict-ref "dict" 0 d key)])]
[(d key default)
(cond
[(hash? d) (hash-ref d key default)]
@ -170,7 +170,7 @@
[(dict-struct? d)
((get-dict-ref (dict-struct-ref d)) d key default)]
[else
(raise-type-error 'dict-ref 'dict 0 d key default)])]))
(raise-type-error 'dict-ref "dict" 0 d key default)])]))
(define (dict-set! d key val)
(cond

17
collects/scheme/package.ss
View File

@ -2,7 +2,8 @@
(require (for-syntax scheme/base
syntax/kerncase
syntax/boundmap
syntax/define))
syntax/define
syntax/flatten-begin))
(provide define-package
package-begin
@ -93,6 +94,12 @@
hidden)
id)))
(define-for-syntax (move-props orig new)
(datum->syntax new
(syntax-e new)
orig
orig))
(define-for-syntax (do-define-package stx exp-stx)
(syntax-case exp-stx ()
[(_ pack-id mode exports form ...)
@ -293,7 +300,7 @@
(car def-ctxes)))])
(syntax-case expr (begin)
[(begin . rest)
(loop (append (syntax->list #'rest) (cdr exprs))
(loop (append (flatten-begin expr) (cdr exprs))
rev-forms
def-ctxes)]
[(def (id ...) rhs)
@ -315,7 +322,7 @@
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
(register-bindings! ids)
(loop (cdr exprs)
(cons #`(define-syntaxes #,ids rhs)
(cons (move-props expr #`(define-syntaxes #,ids rhs))
rev-forms)
(if star? (cons def-ctx def-ctxes) def-ctxes)))))]
[(def (id ...) rhs)
@ -325,7 +332,7 @@
(let ([star? (free-identifier=? #'def #'-define*-values)]
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context)
(syntax-local-make-definition-context (car def-ctxes))
(car def-ctxes))]
[ids (if star?
(map (add-package-context (list def-ctx)) ids)
@ -333,7 +340,7 @@
(syntax-local-bind-syntaxes ids #f def-ctx)
(register-bindings! ids)
(loop (cdr exprs)
(cons #`(define-values #,ids rhs) rev-forms)
(cons (move-props expr #`(define-values #,ids rhs)) rev-forms)
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
[else
(loop (cdr exprs)

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

@ -11,6 +11,7 @@
syntax/name
syntax/context
syntax/define
syntax/flatten-begin
syntax/private/boundmap
mzlib/stxparam
"classidmap.ss"))
@ -245,9 +246,9 @@
null
(let ([e (expand (car l))])
(syntax-case e (begin define-syntaxes define-values)
[(begin expr ...)
[(begin . _)
(loop (append
(syntax->list (syntax (expr ...)))
(flatten-begin e)
(cdr l)))]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
@ -1131,6 +1132,8 @@
(if (null? l)
null
(cons pos (loop (add1 pos) (cdr l)))))]
[(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))]
[(local-field-mutator ...) (generate-temporaries (append field-names private-field-names))]
[(plain-init-name ...) (definify plain-init-names)]
[(plain-init-name-localized ...) (map lookup-localize plain-init-names)]
[(local-plain-init-name ...) (generate-temporaries plain-init-names)])
@ -1164,9 +1167,9 @@
(quote the-obj)
(quote-syntax local-field)
(quote-syntax local-field-localized)
(quote-syntax local-accessor)
(quote-syntax local-mutator)
'(local-field-pos))
(quote-syntax local-field-accessor)
(quote-syntax local-field-mutator)
'())
...
(make-rename-super-map (quote-syntax the-finder)
(quote the-obj)
@ -1324,126 +1327,130 @@
rename-super-temp ... rename-super-extra-temp ...
rename-inner-temp ... rename-inner-extra-temp ...
method-accessor ...) ; for a local call that needs a dynamic lookup
(syntax-parameterize
([this-param (make-this-map (quote-syntax this-id)
(quote-syntax the-finder)
(quote the-obj))])
(let-syntaxes
mappings
(syntax-parameterize
([super-param
(lambda (stx)
(syntax-case stx (rename-super-extra-orig ...)
[(_ rename-super-extra-orig . args)
(generate-super-call
stx
(quote-syntax the-finder)
(quote the-obj)
(quote-syntax rename-super-extra-temp)
(syntax args))]
...
[(_ id . args)
(identifier? #'id)
(raise-syntax-error
#f
(string-append
"identifier for super call does not have an override, "
"override-final, overment, or inherit/super declaration")
stx
#'id)]
[_else
(raise-syntax-error
#f
"expected an identifier after the keyword"
stx)]))]
[inner-param
(lambda (stx)
(syntax-case stx (rename-inner-extra-orig ...)
[(_ default-expr rename-inner-extra-orig . args)
(generate-inner-call
stx
(quote-syntax the-finder)
(quote the-obj)
(syntax default-expr)
(quote-syntax rename-inner-extra-temp)
(syntax args))]
...
[(_ default-expr id . args)
(identifier? #'id)
(raise-syntax-error
#f
(string-append
"identifier for inner call does not have a pubment, augment, "
"overment, or inherit/inner declaration")
stx
#'id)]
[(_)
(raise-syntax-error
#f
"expected a default-value expression after the keyword"
stx
#'id)]
[_else
(raise-syntax-error
#f
"expected an identifier after the keyword and default-value expression"
stx)]))])
stx-def ...
(letrec ([private-temp private-method]
...
[pubment-temp pubment-method]
...
[public-final-temp public-final-method]
...)
(values
(list pubment-temp ... public-final-temp ... . public-methods)
(list . override-methods)
(list . augride-methods)
;; Initialization
#, ;; Attach srcloc (useful for profiling)
(quasisyntax/loc stx
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
(let-syntax ([the-finder (quote-syntax the-obj)])
(syntax-parameterize
([super-instantiate-param
(lambda (stx)
(syntax-case stx ()
[(_ (arg (... ...)) (kw kwarg) (... ...))
(with-syntax ([stx stx])
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
si_leftovers)
(list arg (... ...))
(kw kwarg) (... ...))))]))]
[super-new-param
(lambda (stx)
(syntax-case stx ()
[(_ (kw kwarg) (... ...))
(with-syntax ([stx stx])
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
si_leftovers)
null
(kw kwarg) (... ...))))]))]
[super-make-object-param
(lambda (stx)
(let ([code
(quote-syntax
(lambda args
(super-go the-obj si_c si_inited? si_leftovers args null)))])
(if (identifier? stx)
code
(datum->syntax
code
(cons code
(cdr (syntax-e stx)))))))])
(letrec-syntaxes+values
([(plain-init-name) (make-init-redirect
(quote-syntax set!)
(quote-syntax #%plain-app)
(quote-syntax local-plain-init-name)
(quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) undefined] ...)
(void) ; in case the body is empty
. exprs))))))))))))
(let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)]
...
[local-field-mutator (make-struct-field-mutator local-mutator local-field-pos #f)]
...)
(syntax-parameterize
([this-param (make-this-map (quote-syntax this-id)
(quote-syntax the-finder)
(quote the-obj))])
(let-syntaxes
mappings
(syntax-parameterize
([super-param
(lambda (stx)
(syntax-case stx (rename-super-extra-orig ...)
[(_ rename-super-extra-orig . args)
(generate-super-call
stx
(quote-syntax the-finder)
(quote the-obj)
(quote-syntax rename-super-extra-temp)
(syntax args))]
...
[(_ id . args)
(identifier? #'id)
(raise-syntax-error
#f
(string-append
"identifier for super call does not have an override, "
"override-final, overment, or inherit/super declaration")
stx
#'id)]
[_else
(raise-syntax-error
#f
"expected an identifier after the keyword"
stx)]))]
[inner-param
(lambda (stx)
(syntax-case stx (rename-inner-extra-orig ...)
[(_ default-expr rename-inner-extra-orig . args)
(generate-inner-call
stx
(quote-syntax the-finder)
(quote the-obj)
(syntax default-expr)
(quote-syntax rename-inner-extra-temp)
(syntax args))]
...
[(_ default-expr id . args)
(identifier? #'id)
(raise-syntax-error
#f
(string-append
"identifier for inner call does not have a pubment, augment, "
"overment, or inherit/inner declaration")
stx
#'id)]
[(_)
(raise-syntax-error
#f
"expected a default-value expression after the keyword"
stx
#'id)]
[_else
(raise-syntax-error
#f
"expected an identifier after the keyword and default-value expression"
stx)]))])
stx-def ...
(letrec ([private-temp private-method]
...
[pubment-temp pubment-method]
...
[public-final-temp public-final-method]
...)
(values
(list pubment-temp ... public-final-temp ... . public-methods)
(list . override-methods)
(list . augride-methods)
;; Initialization
#, ;; Attach srcloc (useful for profiling)
(quasisyntax/loc stx
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
(let-syntax ([the-finder (quote-syntax the-obj)])
(syntax-parameterize
([super-instantiate-param
(lambda (stx)
(syntax-case stx ()
[(_ (arg (... ...)) (kw kwarg) (... ...))
(with-syntax ([stx stx])
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
si_leftovers)
(list arg (... ...))
(kw kwarg) (... ...))))]))]
[super-new-param
(lambda (stx)
(syntax-case stx ()
[(_ (kw kwarg) (... ...))
(with-syntax ([stx stx])
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
si_leftovers)
null
(kw kwarg) (... ...))))]))]
[super-make-object-param
(lambda (stx)
(let ([code
(quote-syntax
(lambda args
(super-go the-obj si_c si_inited? si_leftovers args null)))])
(if (identifier? stx)
code
(datum->syntax
code
(cons code
(cdr (syntax-e stx)))))))])
(letrec-syntaxes+values
([(plain-init-name) (make-init-redirect
(quote-syntax set!)
(quote-syntax #%plain-app)
(quote-syntax local-plain-init-name)
(quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) undefined] ...)
(void) ; in case the body is empty
. exprs)))))))))))))
;; Not primitive:
#f))))))))))))))))
@ -2095,9 +2102,9 @@
;; Use public field names to name the accessors and mutators
(let-values ([(inh-accessors inh-mutators)
(values
(map (lambda (id) (make-class-field-accessor super id))
(map (lambda (id) (make-class-field-accessor super id #f))
inherit-field-names)
(map (lambda (id) (make-class-field-mutator super id))
(map (lambda (id) (make-class-field-mutator super id #f))
inherit-field-names))])
;; -- Reset field table to register accessor and mutator info --
;; There are more accessors and mutators than public fields...
@ -2771,8 +2778,10 @@
;; All unconsumed named-args must have #f
;; "name"s, otherwise an error is raised in
;; the leftovers checking.
(append (map (lambda (x) (cons #f x)) al)
named-args)]
(if (null? al)
named-args
(append (map (lambda (x) (cons #f x)) al)
named-args))]
[else
(obj-error 'instantiate
"too many initialization arguments:~a~a"
@ -2950,7 +2959,7 @@
(loop (wrapper-object-wrapped loop-object)))))))
(define (class-field-X who which cwhich class name)
(define (class-field-X who which cwhich class name proc-field-name)
(unless (class? class)
(raise-type-error who "class" class))
(unless (symbol? name)
@ -2960,17 +2969,17 @@
(obj-error who "no such field: ~a~a"
name
(for-class (class-name class)))))])
(which (cwhich (car p)) (cdr p) name)))
(which (cwhich (car p)) (cdr p) proc-field-name)))
(define (make-class-field-accessor class name)
(define (make-class-field-accessor class name keep-name?)
(class-field-X 'class-field-accessor
make-struct-field-accessor class-field-ref
class name))
class name (and keep-name? name)))
(define (make-class-field-mutator class name)
(define (make-class-field-mutator class name keep-name?)
(class-field-X 'class-field-mutator
make-struct-field-mutator class-field-set!
class name))
class name (and keep-name? name)))
(define-struct generic (name applicable))
@ -3051,7 +3060,7 @@
(define-syntaxes (class-field-accessor class-field-mutator generic/form)
(let ([mk
(lambda (make targets)
(lambda (make targets extra-args)
(lambda (stx)
(syntax-case stx ()
[(_ class-expr name)
@ -3063,8 +3072,9 @@
stx
name))
(with-syntax ([name (localize name)]
[make make])
(syntax/loc stx (make class-expr `name))))]
[make make]
[extra-args extra-args])
(syntax/loc stx (make class-expr `name . extra-args))))]
[(_ class-expr)
(raise-syntax-error
#f
@ -3072,9 +3082,9 @@
targets)
stx)])))])
(values
(mk (quote-syntax make-class-field-accessor) "class")
(mk (quote-syntax make-class-field-mutator) "class")
(mk (quote-syntax make-generic/proc) "class or interface"))))
(mk (quote-syntax make-class-field-accessor) "class" (list #'#t))
(mk (quote-syntax make-class-field-mutator) "class" (list #'#t))
(mk (quote-syntax make-generic/proc) "class or interface" null))))
(define-syntax (class-field-accessor-traced stx)
(syntax-case stx ()

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

@ -87,7 +87,7 @@ improve method arity mismatch contract violation error messages?
define-stx)]
[(_ name contract-expr)
(raise-syntax-error 'define/contract
"no body after contract"
"expected a contract expression and a definition body, but found only one expression"
define-stx)]
[(_ name+arg-list contract #:freevars args . body)
(identifier? #'args)

2
collects/scribble/html-render.ss
View File

@ -1119,7 +1119,7 @@
(define/override (render-blockquote t part ri)
`((blockquote ,(if (string? (blockquote-style t))
`([class ,(blockquote-style t)])
`([class ,(regexp-replace #rx"^[\\]" (blockquote-style t) "")])
`())
,@(append-map (lambda (i) (render-block i part ri #f))
(blockquote-paragraphs t)))))

8
collects/scribble/latex-render.ss
View File

@ -403,10 +403,14 @@
(define/override (render-blockquote t part ri)
(let ([kind (or (blockquote-style t) "quote")])
(printf "\\begin{~a}" kind)
(if (regexp-match #rx"^[\\]" kind)
(printf "~a{" kind)
(printf "\\begin{~a}" kind))
(parameterize ([current-table-mode (list "blockquote" t)])
(render-flow (make-flow (blockquote-paragraphs t)) part ri #f))
(printf "\\end{~a}" kind)
(if (regexp-match #rx"^[\\]" kind)
(printf "}")
(printf "\\end{~a}" kind))
null))
(define/override (render-other i part ri)

13
collects/scribble/private/manual-style.ss
View File

@ -199,10 +199,15 @@
`(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang"))))
(define (margin-note . c)
(make-styled-paragraph
(list (make-element "refcolumn"
(list (make-element "refcontent" (decode-content c)))))
"refpara"))
(make-blockquote
"\\refpara"
(list
(make-blockquote
"refcolumn"
(list
(make-blockquote
"refcontent"
(flow-paragraphs (decode-flow c))))))))
(define void-const
(schemeresultfont "#<void>"))

7
collects/scribble/scribble.css
View File

@ -152,9 +152,16 @@ table td {
width: 13em;
font-size: 85%;
border: 0.5em solid #F5F5DC;
margin: 0 0 0 0;
}
.refcontent {
margin: 0 0 0 0;
}
.refcontent p {
margin-top: 0;
margin-bottom: 0;
}
/* ---------------------------------------- */

7
collects/scribble/scribble.tex
View File

@ -42,8 +42,6 @@
\newcommand{\schemeopt}[1]{#1}
\newcommand{\textsub}[1]{$_{\hbox{\textsmaller{#1}}}$}
\newcommand{\textsuper}[1]{$^{\hbox{\textsmaller{#1}}}$}
\newcommand{\refcolumn}[1]{#1}
\newcommand{\refcontent}[1]{#1}
\newcommand{\intextcolor}[2]{\textcolor{#1}{#2}}
\newcommand{\intextrgbcolor}[2]{\textcolor[rgb]{#1}{#2}}
\newcommand{\incolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox{#1}{#2}}}
@ -58,9 +56,12 @@
\newcommand{\noborder}[1]{#1}
\newcommand{\imageleft}[1]{} % drop it
\renewcommand{\smaller}[1]{\textsmaller{#1}}
\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}}
\newcommand{\planetName}[1]{PLane\hspace{-0.1ex}T}
\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}}
\newenvironment{refcolumn}{}{}
\newenvironment{refcontent}{}{}
\newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle}
\newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle}

74
collects/scribblings/framework/color.scrbl
View File

@ -8,25 +8,31 @@
This interface describes how coloring is stopped and started for text
that knows how to color itself. It also describes how to query the
lexical and s-expression structure of the text.
@defmethod*[(((start-colorer (token-sym-style (-> symbol? string?)) (get-token (-> input-port? (values any? symbol? (union false? symbol?) natural-number? natural-number?))) (pairs (listof (list/p symbol? symbol?)))) void))]{
@defmethod*[(((start-colorer (token-sym->style (-> symbol? string?))
(get-token (-> input-port? (values any/c
symbol?
(or/c false? symbol?)
exact-nonnegative-integer?
exact-nonnegative-integer?)))
(pairs (listof (list/p symbol? symbol?)))) void))]{
Starts tokenizing the buffer for coloring and parenthesis matching.
token-sym-style will be passed the first return symbol from get-token
The @scheme[token-sym->style] argument will be passed the first return symbol from @scheme[get-token]
and should return the style-name that the token should be colored.
get-token takes an input port and returns the next token as 5 values:
The @scheme[get-token] argument takes an input port and returns the next token as 5 values:
@itemize[
@item{
An unused value. This value is intended to represent the textual
component of the token and may be used as such in the future.}
@item{
A symbol describing the type of the token. This symbol is transformed
into a style-name via the token-sym->style argument. The symbols
'white-space and 'comment have special meaning and should always be
into a style-name via the @scheme[token-sym->style] argument. The symbols
@scheme['white-space] and @scheme['comment] have special meaning and should always be
returned for white space and comment tokens respectively. The symbol
@scheme['no-color] can be used to indicate that although the token is not white
space, it should not be colored. The symbol 'eof must be used to
space, it should not be colored. The symbol @scheme['eof] must be used to
indicate when all the tokens have been consumed.}
@item{
A symbol indicating how the token should be treated by the paren
@ -36,7 +42,7 @@
@item{
The ending position of the token.}]
get-token will usually be implemented with a lexer using the
The @scheme[get-token] function will usually be implemented with a lexer using the
@scheme[parser-tools/lex] library.
get-token must obey the following invariants:
@itemize[
@ -44,7 +50,7 @@
Every position in the buffer must be accounted for in exactly one
token.}
@item{
The token returned by get-token must rely only on the contents of the
The token returned by @scheme[get-token] must rely only on the contents of the
input port argument. This means that the tokenization of some part of
the input cannot depend on earlier parts of the input.}
@item{
@ -57,25 +63,25 @@
the buffer look like:
@verbatim{" 1 2 3"}
would result in a single string token modifying previous tokens. To
handle these situations, get-token must treat the first line as a
handle these situations, @scheme[get-token] must treat the first line as a
single token.}]
@scheme[pairs] is a list of different kinds of matching parens. The second
The @scheme[pairs] argument is a list of different kinds of matching parens. The second
value returned by get-token is compared to this list to see how the
paren matcher should treat the token. An example: Suppose pairs is
@scheme['((|(| |)|) (|[| |]|) (begin end))]. This means that there
are three kinds of parens. Any token which has 'begin as its second
return value will act as an open for matching tokens with 'end.
are three kinds of parens. Any token which has @scheme['begin] as its second
return value will act as an open for matching tokens with @scheme['end].
Similarly any token with @scheme['|]|] will act as a closing match for
tokens with @scheme['|[|]. When trying to correct a mismatched
closing parenthesis, each closing symbol in pairs will be converted to
a string and tried as a closing parenthesis.
}
@defmethod*[(((stop-colorer (clear-colors boolean |#t|)) void))]{
@defmethod*[(((stop-colorer (clear-colors boolean #t)) void))]{
Stops coloring and paren matching the buffer.
If clear-colors is true all the text in the buffer will have it's
If @scheme[clear-colors] is true all the text in the buffer will have its
style set to Standard.
}
@defmethod*[(((force-stop-colorer (stop? boolean?)) void))]{
@ -83,7 +89,7 @@
Intended for debugging purposes only.
stop? determines whether the system is being forced to stop or allowed
@scheme[stop?] determines whether the system is being forced to stop or allowed
to wake back up.
}
@defmethod*[(((is-stopped?) boolean?))]{
@ -96,27 +102,25 @@
and
@method[color:text<%> thaw-colorer].
}
@defmethod*[(((freeze-colorer) void))]{
Keep the text tokenized and paren matched, but stop altering the colors.
freeze-colorer will not return until the coloring/tokenization of the
@scheme[freeze-colorer] will not return until the coloring/tokenization of the
entire text is brought up-to-date. It must not be called on a locked
text.
}
@defmethod*[(((thaw-colorer (recolor boolean |#t|) (retokenize boolean |#f|)) void))]{
@defmethod*[(((thaw-colorer (recolor boolean #t) (retokenize boolean #f)) void))]{
Start coloring a frozen buffer again.
If recolor? is @scheme[#t], the text is re-colored. If it is
@scheme[#f] the text is not recolored. When recolor? is @scheme[#t],
retokenize? controls how the text is recolored. @scheme[#f] causes
If @scheme[recolor?] is @scheme[#t], the text is re-colored. If it is
@scheme[#f] the text is not recolored. When @scheme[recolor?] is @scheme[#t],
@scheme[retokenize?] controls how the text is recolored. @scheme[#f] causes
the text to be entirely re-colored before thaw-colorer returns using
the existing tokenization. @scheme[#t] causes the entire text to be
retokenized and recolored from scratch. This will happen in the
background after the call to thaw-colorer returns.
background after the call to @scheme[thaw-colorer] returns.
}
@defmethod*[(((reset-region (start natural-number?) (end (union (quote end) natural-number?))) void))]{
@ -134,19 +138,16 @@
@defmethod*[(((skip-whitespace (position natural-number?) (direction (symbols (quote forward) (quote backward))) (comments? boolean?)) natural-number?))]{
Returns the next non-whitespace character.
Starts from position and skips whitespace in the direction indicated
by direction. If comments? is true, comments are skipped as well as
by direction. If @scheme[comments?] is true, comments are skipped as well as
whitespace. skip-whitespace determines whitespaces and comments by
comparing the token type to 'white-space and 'comment.
comparing the token type to @scheme['white-space] and @scheme['comment].
Must only be called while the tokenizer is started.
}
@defmethod*[(((backward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{
Skip all consecutive whitespaces and comments (using skip-whitespace)
Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace])
immediately preceding the position. If the token at this position is
a close, return the position of the matching open, or @scheme[#f] if
there is none. If the token was an open, return @scheme[#f]. For any
@ -163,9 +164,7 @@
}
@defmethod*[(((forward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{
Skip all consecutive whitespaces and comments (using skip-whitespace)
Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace])
immediately following position. If the token at this position is an
open, return the position of the matching close, or @scheme[#f] if
there is none. For any other token, return the end of that token.
@ -174,12 +173,11 @@
}
@defmethod*[(((insert-close-paren (position natural-number?) (char char?) (flash? boolean?) (fixup? boolean?)) void))]{
Position is the place to put the parenthesis and char is the
parenthesis to be added. If fixup? is true, the right kind of closing
parenthesis to be added. If @scheme[fixup?] is true, the right kind of closing
parenthesis will be chosen from the pairs list kept last passed to
start-colorer, otherwise char will be inserted, even if it is not the
right kind. If flash? is true the matching open parenthesis will be
@scheme[start-colorer], otherwise char will be inserted, even if it is not the
right kind. If @scheme[flash?] is true the matching open parenthesis will be
flashed.
}
@defmethod*[(((classify-position (position natural-number?)) symbol?))]{
@ -218,7 +216,9 @@
@defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{
This mixin adds coloring functionality to the mode.
@defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |scheme(λ (x) "Standard"))|) (matches (listof (list/c symbol? symbol?)) null))]{
@defconstructor[((get-token lexer default-lexer)
(token-sym->style (symbol? . -> . string?) (λ (x) "Standard"))
(matches (listof (list/c symbol? symbol?)) null))]{
The arguments are passed to
@method[color:text<%> start-colorer].

4
collects/scribblings/framework/scheme.scrbl
View File

@ -57,7 +57,7 @@
The result of this method is used to determine if the return key
automatically tabs over to the correct position.
Override it to change it's behavior.
Override it to change its behavior.
}
@ -199,7 +199,7 @@
}
@defmethod*[(((mark-matching-parenthesis (pos exact-positive-integer)) void))]{
If the paren after @scheme[pos] is matched, this method
highlights it and it's matching counterpart in dark green.
highlights it and its matching counterpart in dark green.
}
@defmethod*[(((get-tab-size) exact-integer))]{

2
collects/scribblings/gui/editor-intf.scrbl
View File

@ -1826,7 +1826,7 @@ See @method[editor<%> read-header-from-file].
@defmethod[(read-from-file [stream (is-a?/c editor-stream-in%)]
[overwrite-styles? any/c #t])
[overwrite-styles? any/c #f])
boolean?]{
Reads new contents for the editor from a stream. The return value is

8
collects/scribblings/gui/editor-stream-in-base-class.scrbl
View File

@ -37,6 +37,14 @@ Reads bytes to fill the supplied byte string. The return value is the
next call to @method[editor-stream-in-base% bad?] must return
@scheme[#t].}
@defmethod[(read-byte) (or/c byte? #f)]{
Reads a single byte and return it, or returns @scheme[#f] if no more
bytes are available. The default implementation of this method uses
@method[editor-stream-in-base% read-bytes].
}
@defmethod[(seek [pos exact-nonnegative-integer?])
void?]{

10
collects/scribblings/gui/editor-stream-in-class.scrbl
View File

@ -54,12 +54,18 @@ Returns the next integer value in the stream.
@defmethod[(get-fixed [v (box/c (and/c exact? integer?))])
(is-a?/c editor-stream-in%)]{
@boxisfill[(scheme v) @elem{a fixed-size integer from the stream obtained through
@method[editor-stream-in% get-fixed-exact]}]
}
@defmethod[(get-fixed-exact)
(and/c exact? integer?)]{
Gets a fixed-sized integer from the stream. See
@method[editor-stream-out% put-fixed] for more information.
Reading from a bad stream always gives @scheme[0].
@boxisfill[(scheme v) @elem{the fixed-size integer from the stream}]
}
@defmethod[(get-inexact)

3
collects/scribblings/gui/editor-stream-out-class.scrbl
View File

@ -86,7 +86,8 @@ Puts a fixed-sized integer into the stream. This method is needed
fixed-size number.
Numbers written to a stream with @method[editor-stream-out% put-fixed]
must be read with @method[editor-stream-in% get-fixed].}
must be read with @method[editor-stream-in% get-fixed-exact]
or @method[editor-stream-in% get-fixed].}
@defmethod[(put-unterminated [v bytes?]) (is-a?/c editor-stream-out%)]{

2
collects/scribblings/gui/text-class.scrbl
View File

@ -1698,7 +1698,7 @@ Returns the paragraph number of the paragraph containing a given @techlink{posit
@defmethod[#:mode extend
(read-from-file [stream (is-a?/c editor-stream-in%)]
[start (or/c exact-nonnegative-integer? (one/of 'start))]
[overwrite-styles? any/c #t])
[overwrite-styles? any/c #f])
boolean?]{
New data is inserted at the @techlink{position} indicated by @scheme[start], or at

14
collects/scribblings/guide/contracts-simple-function.scrbl
View File

@ -78,7 +78,7 @@ argument and for the result. When all you have, however, is a Scheme name,
such as @scheme[create] or @scheme[deposit], you want to tell the
reader what the name represents (a function) and, if it is a function (or
some other complex value) what the pieces are supposed to be. This is why
we use a @scheme[->] to say "hey, expect this to be a function."
we use a @scheme[->] to say ``hey, expect this to be a function.''
So @scheme[->] says ``this is a contract for a function.'' What follows
in a function contracts are contracts (sub-contracts if you wish) that tell
@ -93,8 +93,8 @@ number, and a boolean. Its result is an account.
In short, the arrow @scheme[->] is a @italic{contract
combinator}. Its purpose is to combine other contracts into a contract
that says "this is a function @italic{and} its arguments and its result are
like that."
that says ``this is a function @italic{and} its arguments and its result
are like that.''
@ctc-section[#:tag "dots"]{Infix Contract Notation}
@ -219,7 +219,7 @@ scheme
(define (has-decimal? str)
(define L (string-length str))
(and (>= L 3)
(char=? #\. (string-ref result (- L 3)))))
(char=? #\. (string-ref str (- L 3)))))
(provide/contract
(code:comment "convert a random number to a string")
@ -253,15 +253,15 @@ scheme
(define (has-decimal? str)
(define L (string-length str))
(and (>= L 3)
(char=? #\. (string-ref result (- L 3)))))
(char=? #\. (string-ref str (- L 3)))))
(define (is-decimal-string? str)
(define L (string-length str))
(and (has-decimal? str)
(andmap digit-char?
(string->list (substring result 0 (- L 3))))
(string->list (substring str 0 (- L 3))))
(andmap digit-char?
(string->list (substring result (- L 2) L)))))
(string->list (substring str (- L 2) L)))))
(provide/contract
...

13
collects/scribblings/guide/simple-data.scrbl
View File

@ -15,10 +15,9 @@ and imaginary numbers:
@moreguide["numbers"]{numbers}
@schemeblock[
1 1.0
1/2 0.5
9999999999999999999999 1e+22
1+2i 1.0+2.0i
1 3.14
1/2 6.02e+23
1+2i 9999999999999999999999
]
@defterm{Booleans} are @scheme[#t] for true and @scheme[#f] for
@ -36,8 +35,8 @@ appear in a string constant.
@moreguide["strings"]{strings}
@schemeblock[
"hello world"
"A \"fancy\" string"
"Hello, world!"
"Benjamin \"Bugsy\" Siegel"
"\u03BBx:(\u03BC\u03B1.\u03B1\u2192\u03B1).xx"
]
@ -49,5 +48,5 @@ difference between an input expression and a printed result.
@examples[
(eval:alts (unsyntax (schemevalfont "1.0000")) 1.0000)
(eval:alts (unsyntax (schemevalfont "\"A \\u0022fancy\\u0022 string\"")) "A \u0022fancy\u0022 string")
(eval:alts (unsyntax (schemevalfont "\"Bugs \\u0022Figaro\\u0022 Bunny\"")) "Bugs \u0022Figaro\u0022 Bunny")
]

92
collects/scribblings/guide/simple-syntax.scrbl
View File

@ -81,11 +81,11 @@ the last @nonterm{expr}.
@defexamples[
#:eval ex-eval
(code:line (define five 5) (code:comment #, @t{defines @scheme[five] to be @scheme[5]}))
(code:line (define pie 3) (code:comment #, @t{defines @scheme[pie] to be @scheme[3]}))
(code:line (define (piece str) (code:comment #, @t{defines @scheme[piece] as a function})
(substring str 0 five)) (code:comment #, @t{of one argument}))
five
(piece "hello world")
(substring str 0 pie)) (code:comment #, @t{ of one argument}))
pie
(piece "key lime")
]
Under the hood, a function definition is really the same as a
@ -100,8 +100,6 @@ piece
substring
]
@; FIXME: check that everything says "procedure" and not "primitive"
A function definition can include multiple expressions for the
function's body. In that case, only the value of the last expression
is returned when the function is called. The other expressions are
@ -109,30 +107,30 @@ evaluated only for some side-effect, such as printing.
@defexamples[
#:eval ex-eval
(define (greet name)
(printf "returning a greeting for ~a...\n" name)
(string-append "hello " name))
(greet "universe")
(define (bake flavor)
(printf "pre-heating oven...\n")
(string-append flavor " pie"))
(bake "apple")
]
Scheme programmers prefer to avoid assignment statements. It's
Scheme programmers prefer to avoid side-effects. It's
important, though, to understand that multiple expressions are allowed
in a definition body, because it explains why the following
@scheme[nogreet] function simply returns its argument:
@scheme[nobake] function simply returns its argument:
@def+int[
#:eval ex-eval
(define (nogreet name)
string-append "hello " name)
(nogreet "world")
(define (nobake flavor)
string-append flavor "jello")
(nobake "green")
]
Within @scheme[nogreet], there are no parentheses around
@scheme[string-append "hello " name], so they are three separate
Within @scheme[nobake], there are no parentheses around
@scheme[string-append flavor "jello"], so they are three separate
expressions instead of one function-call expression. The expressions
@scheme[string-append] and @scheme["hello "] are evaluated, but the
@scheme[string-append] and @scheme[flavor] are evaluated, but the
results are never used. Instead, the result of the function is just
the result of the expression @scheme[name].
the result of the final expression, @scheme["jello"].
@; ----------------------------------------------------------------------
@section[#:tag "indentation"]{An Aside on Indenting Code}
@ -161,13 +159,14 @@ next line under the first argument, instead of under the
@scheme[define] keyword:
@schemeblock[
(define (nogreet name
(string-append "hello " name)))
(define (halfbake flavor
(string-append flavor " creme brulee")))
]
Furthermore, when an open parenthesis has no matching close
parenthesis in a program, both @exec{mzscheme} and DrScheme use the
source's indentation to suggest where it might be missing.
In this case, indentation helps highlight the mistake. In other cases,
where the indentation may be normal while an open parenthesis has no
matching close parenthesis; both @exec{mzscheme} and DrScheme use the
source's indentation to suggest where a parenthesis might be missing.
@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@section{Identifiers}
@ -193,11 +192,11 @@ more examples:
@schemeblock[
#, @schemeid[+]
#, @schemeid[Apple]
#, @schemeid[Hfuhruhurr]
#, @schemeid[integer?]
#, @schemeid[call/cc]
#, @schemeid[call-with-composable-continuation]
#, @schemeid[x-1+3i]
#, @schemeid[pass/fail]
#, @schemeid[john-jacob-jingleheimer-schmidt]
#, @schemeid[a-b-c+1-2-3]
]
@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@ -225,10 +224,10 @@ pre-defined names are hyperlinked to the reference manual. So, you can
click on an identifier to get full details about its use.
@interaction[
(code:line (string-append "hello" " " "scheme") (code:comment #, @t{append strings}))
(code:line (substring "hello scheme" 6 12) (code:comment #, @t{extract a substring}))
(code:line (string-length "scheme") (code:comment #, @t{get a string's length}))
(code:line (string? "hello scheme") (code:comment #, @t{recognize strings}))
(code:line (string-append "rope" "twine" "yarn") (code:comment #, @t{append strings}))
(code:line (substring "corduroys" 0 4) (code:comment #, @t{extract a substring}))
(code:line (string-length "shoelace") (code:comment #, @t{get a string's length}))
(code:line (string? "c'est ne pas une string") (code:comment #, @t{recognize strings}))
(string? 1)
(code:line (sqrt 16) (code:comment #, @t{find a square root}))
(sqrt -16)
@ -236,10 +235,11 @@ click on an identifier to get full details about its use.
(code:line (- 2 1) (code:comment #, @t{subtract numbers}))
(code:line (< 2 1) (code:comment #, @t{compare numbers}))
(>= 2 1)
(code:line (number? "hello scheme") (code:comment #, @t{recognize numbers}))
(code:line (number? "c'est une number") (code:comment #, @t{recognize numbers}))
(number? 1)
(code:line (equal? 1 "hello") (code:comment #, @t{compare anything}))
(equal? 1 1)
(code:line (equal? 6 "half dozen") (code:comment #, @t{compare anything}))
(equal? 6 6)
(equal? "half dozen" "half dozen")
]
@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@ -403,7 +403,7 @@ expression:
@def+int[
(define (double v)
((if (string? v) string-append +) v v))
(double "hello")
(double "mnah")
(double 5)
]
@ -581,9 +581,12 @@ each clause, the @nonterm{id} is bound to the result of the
@nonterm{expr} for use in the body.
@interaction[
(let ([x 1]
[y 2])
(format "adding ~s and ~s produces ~s" x y (+ x y)))
(let ([x (random 4)]
[o (random 4)])
(cond
[(> x o) "X wins"]
[(> o x) "O wins"]
[else "cat's game"]))
]
The bindings of a @scheme[let] form are available only in the body of
@ -592,10 +595,13 @@ other. The @scheme[let*] form, in contrast, allows later clauses to
use earlier bindings:
@interaction[
(let* ([x 1]
[y 2]
[z (+ x y)])
(format "adding ~s and ~s produces ~s" x y z))
(let* ([x (random 4)]
[o (random 4)]
[diff (number->string (abs (- x o)))])
(cond
[(> x o) (string-append "X wins by " diff)]
[(> o x) (string-append "O wins by " diff)]
[else "cat's game"]))
]
@; ----------------------------------------------------------------------

58
collects/scribblings/guide/welcome.scrbl
View File

@ -2,7 +2,8 @@
@(require scribble/manual
scribble/eval
scribble/bnf
"guide-utils.ss")
"guide-utils.ss"
(for-label scheme/enter))
@(define piece-eval (make-base-eval))
@ -85,16 +86,16 @@ number:
A string is also an expression that evaluates to itself. A string is
written with double quotes at the start and end of the string:
@interaction["hello world"]
@interaction["Hello, world!"]
Scheme uses parentheses to wrap larger expressions---almost any kind
of expression, other than simple constants. For example, a function
call is written: open parenthesis, function name, argument
expression, and closing parenthesis. The following expression calls
the built-in function @scheme[substring] with the arguments
@scheme["hello world"], @scheme[0], and @scheme[5]:
@scheme["the boy out of the country"], @scheme[4], and @scheme[7]:
@interaction[(substring "hello world" 0 5)]
@interaction[(substring "the boy out of the country" 4 7)]
@; ----------------------------------------------------------------------
@section{Definitions and Interactions}
@ -104,9 +105,10 @@ using the @scheme[define] form, like this:
@def+int[
#:eval piece-eval
(define (piece str)
(substring str 0 5))
(piece "howdy universe")
(define (extract str)
(substring str 4 7))
(extract "the boy out of the country")
(extract "the country out of the boy")
]
Although you can evaluate the @scheme[define] form in the @tech{REPL},
@ -118,29 +120,29 @@ top text area---called the @deftech{definitions area}---along with the
@schememod[
scheme
code:blank
(define (piece str)
(substring str 0 5))
(define (extract str)
(substring str 4 7))
]
If calling @scheme[(piece "howdy universe")] is part of the main
action of your program, that would go in the @tech{definitions area},
too. But if it was just an example expression that you were using to
explore @scheme[piece], then you'd more likely leave the
@tech{definitions area} as above, click @onscreen{Run}, and then
evaluate @scheme[(piece "howdy universe")] in the @tech{REPL}.
If calling @scheme[(extract "the boy")] is part of the main action of
your program, that would go in the @tech{definitions area}, too. But
if it was just an example expression that you were using to explore
@scheme[extract], then you'd more likely leave the @tech{definitions
area} as above, click @onscreen{Run}, and then evaluate
@scheme[(extract "the boy")] in the @tech{REPL}.
With @exec{mzscheme}, you'd save the above text in a file using your
favorite editor. If you save it as @filepath{piece.ss}, then after starting
favorite editor. If you save it as @filepath{extract.ss}, then after starting
@exec{mzscheme} in the same directory, you'd evaluate the following
sequence:
@interaction[
#:eval piece-eval
(eval:alts (enter! "piece.ss") (void))
(piece "howdy universe")
(eval:alts (enter! "extract.ss") (void))
(extract "the gal out of the city")
]
The @scheme[enter!] function both loads the code and switches the
The @scheme[enter!] form both loads the code and switches the
evaluation context to the inside of the module, just like DrScheme's
@onscreen{Run} button.
@ -152,13 +154,13 @@ If your file (or @tech{definitions area} in DrScheme) contains
@schememod[
scheme
(define (piece str)
(substring str 0 5))
(define (extract str)
(substring str 4 7))
(piece "howdy universe")
(extract "the cat out of the bag")
]
then it is a complete program that prints ``howdy'' when run. To
then it is a complete program that prints ``cat'' when run. To
package this program as an executable, choose one of the following
options:
@ -200,16 +202,16 @@ If you already know something about Scheme or Lisp, you might be
tempted to put just
@schemeblock[
(define (piece str)
(substring str 0 5))
(define (extract str)
(substring str 4 7))
]
into @filepath{piece.scm} and run @exec{mzscheme} with
into @filepath{extract.scm} and run @exec{mzscheme} with
@interaction[
#:eval piece-eval
(eval:alts (load "piece.scm") (void))
(piece "howdy universe")
(eval:alts (load "extract.scm") (void))
(extract "the dog out")
]
That will work, because @exec{mzscheme} is willing to imitate a

20
collects/scribblings/htdp-langs/advanced.scrbl
View File

@ -4,18 +4,24 @@
"prim-ops.ss"
(for-label lang/htdp-advanced))
@(define-syntax-rule (bd intm-define intm-define-struct intm-lambda intm-local intm-letrec intm-let intm-let* intm-time)
@(define-syntax-rule (bdl intm-define intm-lambda)
(begin
(require (for-label lang/htdp-intermediate-lambda))
(define intm-define (scheme define))
(define intm-lambda (scheme lambda))))
@(bdl intm-define intm-lambda)
@(define-syntax-rule (bd intm-define-struct intm-local intm-letrec intm-let intm-let* intm-time)
(begin
(require (for-label lang/htdp-intermediate))
(define intm-define (scheme define))
(define intm-define-struct (scheme define-struct))
(define intm-lambda (scheme lambda))
(define intm-local (scheme local))
(define intm-letrec (scheme letrec))
(define intm-let (scheme let))
(define intm-let* (scheme let*))
(define intm-time (scheme time))))
@(bd intm-define intm-define-struct intm-lambda intm-local intm-letrec intm-let intm-let* intm-time)
@(bd intm-define-struct intm-local intm-letrec intm-let intm-let* intm-time)
@(define-syntax-rule (bbd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-check-expect beg-require)
(begin
@ -36,7 +42,7 @@
@declare-exporting[lang/htdp-advanced]
@schemegrammar*+qq[
#:literals (define define-struct lambda cond else if and or empty true false require lib planet
#:literals (define define-struct lambda λ cond else if and or empty true false require lib planet
local let let* letrec time begin begin0 set! delay shared recur when case unless
check-expect check-within check-error)
(check-expect check-within check-error require)
@ -53,6 +59,7 @@
(set! id expr)
(delay expr)
(lambda (id ...) expr)
(λ (id ...) expr)
(local [definition ...] expr)
(letrec ([id expr] ...) expr)
(shared ([id expr] ...) expr)
@ -126,7 +133,10 @@ additional set of operations:
@section[#:tag "advanced-lambda"]{@scheme[lambda]}
@defform[(lambda (id ...) expr)]{
@deftogether[(
@defform[(lambda (id ...) expr)]
@defform[(λ (id ...) expr)]
)]{
The same as Intermediate with Lambda's @|intm-lambda|, except that a
function is allowed to accept zero arguments.}

7
collects/scribblings/htdp-langs/intermediate-lambda.scrbl
View File

@ -35,7 +35,7 @@
@declare-exporting[lang/htdp-intermediate-lambda]
@schemegrammar*+qq[
#:literals (define define-struct lambda cond else if and or empty true false require lib planet
#:literals (define define-struct lambda λ cond else if and or empty true false require lib planet
local let let* letrec time check-expect check-within check-error)
(check-expect check-within check-error require)
[program (code:line def-or-expr ...)]
@ -47,6 +47,7 @@
(define id expr)
(define-struct id (id ...))]
[expr (lambda (id id ...) expr)
(λ (id id ...) expr)
(local [definition ...] expr)
(letrec ([id expr] ...) expr)
(let ([id expr] ...) expr)
@ -97,6 +98,10 @@ for @scheme[lambda], since a @scheme[lambda] form is an expression.}
Creates a function that takes as many arguments as given @scheme[id]s,
and whose body is @scheme[expr].}
@defform[(λ (id id ...) expr)]{
The Greek letter @scheme[λ] is a synonym for @scheme[lambda].}
@; ----------------------------------------------------------------------
@section[#:tag "intermediate-lambda-call"]{Function Calls}

8
collects/scribblings/inside/ports.scrbl
View File

@ -463,9 +463,9 @@ The functions are as follows.
Called to obtain a progress event for the port, such as for
@scheme[port-progress-evt]. This function can be @cpp{NULL} if the
port does not support progress events. Use
@cpp{progress_evt_via_get} to obtain a default implementation, in
@cpp{scheme_progress_evt_via_get} to obtain a default implementation, in
which case @var{peeked_read_fun} should be
@cpp{peeked_read_via_get}, and @var{get_bytes_fun} and
@cpp{scheme_peeked_read_via_get}, and @var{get_bytes_fun} and
@var{peek_bytes_fun} should handle @var{unless} as described
above.}
@ -477,9 +477,9 @@ The functions are as follows.
Called to commit previously peeked bytes, just like the sixth
argument to @scheme[make-input-port]. Use
@cpp{peeked_read_via_get} for the default implementation of
@cpp{scheme_peeked_read_via_get} for the default implementation of
commits when @var{progress_evt_fun} is
@cpp{progress_evt_via_get}.}
@cpp{scheme_progress_evt_via_get}.}
@subfunction[(int char_ready_fun
[Scheme_Input_Port* port])]{

4
collects/scribblings/mzc/zo-parse.scrbl
View File

@ -14,7 +14,7 @@
@defproc[(zo-parse [in input-port?]) compilation-top?]{
Parses a port (typically the result of opening a @filepath{.zo} file)
containing byte. Beware that the structure types used to represent the
containing bytecode. Beware that the structure types used to represent the
bytecode are subject to frequent changes across PLT Scheme versons.
The parsed bytecode is returned in a @scheme[compilation-top]
@ -23,7 +23,7 @@ structure will contain a @scheme[mod] structure. For a top-level
sequence, it will normally contain a @scheme[seq] or @scheme[splice]
structure with a list of top-level declarations and expressions.
The bytecode representation f an expression is closer to an
The bytecode representation of an expression is closer to an
S-expression than a traditional, flat control string. For example, an
@scheme[if] form is represented by a @scheme[branch] structure that
has three fields: a test expression, a ``then'' expression, and an

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

@ -146,7 +146,7 @@ must merely start with a chain of at least @scheme[pos] pairs.}
@defproc*[([(append [lst list?] ...) list?]
[(append [lst list?] ... [v any/c]) any/c])]{
When given all list arguments, the result is a lists that contains all
When given all list arguments, the result is a list that contains all
of the elements of the given lists in order. The last argument is used
directly in the tail of the result.
@ -211,10 +211,10 @@ Similar to @scheme[map], except that
@item{the result of the first applciation of @scheme[proc] to produces a
value other than @scheme[#f], in which case @scheme[proc] is not
applied to later elements of the @scheme[lst]s; more specifically,
applied to later elements of the @scheme[lst]s;
the application of @scheme[proc] to the last elements in the
@scheme[lst]s is in tail position with respect to the
@scheme[andmap] call.}
@scheme[ormap] call.}
]

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

@ -147,7 +147,7 @@ opposed to using @scheme[in] directly as a sequence to get bytes).}
sequence?]{
Returns a sequence whose elements are the result of @scheme[(read-line
in mode)] until an end-of-line is encountered. Note that the default
in mode)] until an end-of-file is encountered. Note that the default
mode is @scheme['any], whereas the default mode of @scheme[read-line]
is @scheme['linefeed].}

6
collects/scribblings/reference/startup.scrbl
View File

@ -138,7 +138,11 @@ flags:
@item{@FlagFirst{p} @nonterm{file} @nonterm{u} @nonterm{path} :
@scheme[require]s @scheme[(planet #, @nontermstr{file}
#, @nontermstr{user} #, @nontermstr{pkg})].}
#, @nontermstr{user} #, @nontermstr{pkg})].
@margin-note{Despite its name, @DFlag{script} is not usually
used for Unix scripts. See @guidesecref["scripts"] for more
information on scripts.}}
@item{@FlagFirst{r} @nonterm{file} or @DFlagFirst{script}
@nonterm{file} : @scheme[load]s @nonterm{file} as a

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

@ -237,7 +237,8 @@ The result of @scheme[make-struct-type] is five values:
@defproc[(make-struct-field-accessor [accessor-proc struct-accessot-procedure?]
[field-pos exact-nonnegative-integer?]
[field-name symbol?])
[field-name (or/c symbol? #f)
(symbol->string (format "field~a" field-pos))])
procedure?]{
Returns a field accessor that is equivalent to @scheme[(lambda (s)
@ -245,13 +246,14 @@ Returns a field accessor that is equivalent to @scheme[(lambda (s)
an @tech{accessor} returned by @scheme[make-struct-type]. The name of the
resulting procedure for debugging purposes is derived from
@scheme[field-name] and the name of @scheme[accessor-proc]'s
structure type.
structure type if @scheme[field-name] is a symbol.
For examples, see @scheme[make-struct-type].}
@defproc[(make-struct-field-mutator [mutator-proc struct-mutator-procedure?]
[field-pos exact-nonnegative-integer?]
[field-name symbol?])
[field-name (or/c symbol? #f)
(symbol->string (format "field~a" field-pos))])
procedure?]{
Returns a field mutator that is equivalent to @scheme[(lambda (s v)
@ -259,7 +261,7 @@ Returns a field mutator that is equivalent to @scheme[(lambda (s v)
a @tech{mutator} returned by @scheme[make-struct-type]. The name of the
resulting procedure for debugging purposes is derived from
@scheme[field-name] and the name of @scheme[mutator-proc]'s
structure type.
structure type if @scheme[field-name] is a symbol.
For examples, see @scheme[make-struct-type].}

6
collects/scribblings/reference/stx-props.scrbl
View File

@ -54,17 +54,17 @@ MzScheme adds properties to expanded syntax (often using
@item{When an internal @scheme[define-values] or
@scheme[define-syntaxes] form is converted into a
@scheme[letrec-values+syntaxes] form (see @secref["intdef-body"]),
@scheme[letrec-syntaxes+values] form (see @secref["intdef-body"]),
@scheme[syntax-track-origin] is applied to each generated binding
clause. The second argument to @scheme[syntax-track-origin] is the
converted form, and the third argument is the @scheme[define-values]
or @scheme[define-syntaxes] keyword form the converted form.}
@item{When a @scheme[letrec-values+syntaxes] expression is fully
@item{When a @scheme[letrec-syntaxes+values] expression is fully
expanded, syntax bindings disappear, and the result is either a
@scheme[letrec-values] form (if the unexpanded form contained
non-syntax bindings), or only the body of the
@scheme[letrec-values+syntaxes] form (wrapped with @scheme[begin] if
@scheme[letrec-syntaxes+values] form (wrapped with @scheme[begin] if
the body contained multiple expressions). To record the disappeared
syntax bindings, a property is added to the expansion result: an
immutable list of identifiers from the disappeared bindings, as a

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

@ -976,11 +976,51 @@ sets of imported identifiers.
@defform[(matching-identifiers-in regexp require-spec)]{ Like
@scheme[require-spec], but including only imports whose names match
@scheme[regexp]. The @scheme[regexp] must be a literal regular
expression (see @secref["regexp"]).}
expression (see @secref["regexp"]).
@defexamples[#:eval (syntax-eval)
(module zoo scheme/base
(provide tunafish swordfish blowfish
monkey lizard ant)
(define tunafish 1)
(define swordfish 2)
(define blowfish 3)
(define monkey 4)
(define lizard 5)
(define ant 6))
(require scheme/require)
(require (matching-identifiers-in #rx"\\w*fish" 'zoo))
tunafish
swordfish
blowfish
monkey
]}
@defform[(subtract-in require-spec subtracted-spec ...)]{ Like
@scheme[require-spec], but omitting those imports that would be
imported by one of the @scheme[subtracted-spec]s.}
imported by one of the @scheme[subtracted-spec]s.
@defexamples[#:eval (syntax-eval)
(module earth scheme
(provide land sea air)
(define land 1)
(define sea 2)
(define air 3))
(module mars scheme
(provide aliens)
(define aliens 4))
(module solar-system scheme
(require 'earth 'mars)
(provide (all-from-out 'earth)
(all-from-out 'mars)))
(require scheme/require)
(require (subtract-in 'solar-system 'earth))
land
aliens
]}
@defform[(filtered-in proc-expr require-spec)]{ The @scheme[proc-expr]
should evaluate to a single-argument procedure, which is applied on

13
collects/scribblings/scribble/config.scrbl
View File

@ -43,12 +43,15 @@ When a string is uses as a style in an @scheme[element],
@scheme[styled-paragraph], @scheme[table],
@scheme[styled-itemization], or @scheme[blockquote], it corresponds to
a CSS class for HTML output or a Tex macro/environment for Latex
output. In Latex output, the string is used as a macro name for a
output. In Latex output, the string is used as a command name for a
@scheme[styled-paragraph] and an environment name for a
@scheme[table], @scheme[itemization], or @scheme[blockquote]. In
addition, for an itemization, the style string is suffixed with
@scheme["Item"] and used as a CSS class or Tex macro name to use for
the itemization's items (in place of @tt{item} in the case of Latex).
@scheme[table], @scheme[itemization], or @scheme[blockquote], except
that a @scheme[blockquote] style name that starts with @litchar{\} is
used (sans @litchar{\}) as a command instead of an environment.
In addition, for an itemization, the style string is
suffixed with @scheme["Item"] and used as a CSS class or Tex macro
name to use for the itemization's items (in place of @tt{item} in the
case of Latex).
Scribble includes a number of predefined styles that are used by the
exports of @scheme[scribble/manual], but they are not generally

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

@ -1140,8 +1140,8 @@ centered table with the @scheme[pre-flow] parsed by
@defproc[(commandline [pre-content any/c] ...) paragraph?]{Produces
an inset command-line example (e.g., in typewriter font).}
@defproc[(margin-note [pre-content any/c] ...) paragraph?]{Produces
a paragraph to be typeset in the margin instead of inlined.}
@defproc[(margin-note [pre-content any/c] ...) blockquote?]{Produces
a @tech{blockquote} to be typeset in the margin instead of inlined.}
@; ------------------------------------------------------------------------
@section[#:tag "index-entries"]{Index-Entry Descriptions}

3
collects/scribblings/scribble/struct.scrbl
View File

@ -476,7 +476,8 @@ The @scheme[style] can be
A @techlink{blockquote} has a style and a list of @tech{blocks}. The
@scheme[style] field is normally a string that corresponds to a CSS
class for HTML output or Latex environment for Latex output (see
class for HTML output or Latex environment for Latex output where a
leading @litchar{\} in the style name is treated specially (see
@secref["extra-style"]).
}

4
collects/slideshow/pict.ss
View File

@ -42,7 +42,7 @@
(list? p)
(andmap pict? p))))
(define (pin-line sz p
(define (pin-line p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
@ -57,7 +57,7 @@
dest dest-find))
p lw col under?)
(pin-curve* #f #f p src src-find dest dest-find
sa ea sp ep sz col lw under? #t)))
sa ea sp ep 0 col lw under? #t)))
(define (pin-arrow-line sz p
src src-find

1
collects/string-constants/german-string-constants.ss
View File

@ -1152,6 +1152,7 @@
(stepper-next "Schritt >")
(stepper-next-application "Applikation >|")
(stepper-jump-to-end "Ende")
(stepper-jump "Springen zu ...")
(debug-tool-button-name "Debugger")

13
collects/syntax/flatten-begin.ss Normal file
View File

@ -0,0 +1,13 @@
#lang scheme/base
(provide flatten-begin)
(define (flatten-begin stx)
(let ([l (syntax->list stx)])
(if l
(map (lambda (e)
(syntax-track-origin e stx (car l)))
(cdr l))
(raise-syntax-error
#f
"bad syntax"
stx))))

3
collects/syntax/modresolve.ss
View File

@ -7,6 +7,9 @@
(cond [(path-string? relto)
(if dir?
(let-values ([(base n d?) (split-path relto)])
(when d?
(error 'resolve-module-path-index
"given a directory path instead of a file path: ~e" relto))
(if (eq? base 'relative)
(or (current-load-relative-directory) (current-directory))
base))

14
collects/syntax/scribblings/flatten-begin.scrbl Normal file
View File

@ -0,0 +1,14 @@
#lang scribble/doc
@(require "common.ss"
(for-label syntax/flatten-begin))
@title[#:tag "flatten-begin"]{Flattening @scheme[begin] Forms}
@defmodule[syntax/flatten-begin]
@defproc[(flatten-begin [stx syntax?]) (listof syntax?)]{
Extracts the sub-expressions from a @scheme[begin]-like form,
reporting an error if @scheme[stx] does not have the right shape
(i.e., a syntax list). The resulting syntax objects have annotations
transferred from @scheme[stx] using @scheme[syntax-track-origin].}

2
collects/syntax/scribblings/transformer-helpers.scrbl
View File

@ -6,6 +6,6 @@
@include-section["name.scrbl"]
@include-section["context.scrbl"]
@include-section["define.scrbl"]
@include-section["flatten-begin.scrbl"]
@include-section["struct.scrbl"]
@include-section["path-spec.scrbl"]

46
collects/tests/honu/basic.honu
View File

@ -13,7 +13,45 @@ obj test(t, a, b){
}
}
var x = 3;
const y = 2;
test("x = 3", x, 3);
test("y = 2", y, 2);
obj test1(){
var x = 3;
const y = 2;
test("x = 3", x, 3);
test("y = 2", y, 2);
}
obj test2(){
obj foo(){
1;
}
obj x1(){
obj x(){
2;
}
x;
}
(-> obj) x2(){
obj x(){
3;
}
x;
}
/*
var anonymous_foo = obj x(){
2;
};
*/
var anonymous_foo = x1();
var x2_x = x2();
test("foo() = 1", foo(), 1);
test("anonymous_foo = 2", anonymous_foo(), 2);
test("x2_x = 3", x2_x(), 3);
}
test1();
test2();

9
collects/tests/mred/wxme.ss
View File

@ -768,12 +768,15 @@
(expect (send fi2 tell) 10)
(send fi2 jump-to 3)
(send fi2 set-boundary 5)
(send fi2 set-boundary 2)
(expect (send fi2 get-unterminated-bytes) #"hi")
(send fi2 jump-to 3)
(expect (send fi2 ok?) #t)
(send fi2 set-boundary 4)
(expect (send fi2 get-unterminated-bytes) #"")
(expect (send fi2 tell) 3)
(send fi2 set-boundary 1)
(expect (with-handlers ([values (lambda (exn) #"")])
(send fi2 get-unterminated-bytes))
#"")
(expect (send fi2 ok?) #f)
;; ----------------------------------------

212
collects/tests/mzscheme/modprot.ss Normal file
View File

@ -0,0 +1,212 @@
(load-relative "loadtest.ss")
(Section 'modprot)
;; ============================================================
;; Use '#%kernel everywhere so we're only checking the directly
;; intended certifications and protections.
(define zero
'(module zero '#%kernel
(define-values (prot) 8)
(#%provide (protect prot))))
;; - - - - - - - - - - - - - - - - - - - -
(define one
'(module one '#%kernel
(#%require 'zero
(for-syntax '#%kernel))
(define-values (unexp) 5)
(define-syntaxes (stx)
(lambda (stx) (quote-syntax 13)))
(define-syntaxes (nab)
(lambda (stx)
(datum->syntax
stx
(list (quote-syntax define-syntaxes)
(cdr (syntax-e stx))
(quote-syntax (make-rename-transformer (quote-syntax unexp)))))))
(define-syntaxes (pnab)
(lambda (stx)
(datum->syntax
stx
(list (quote-syntax define-syntaxes)
(cdr (syntax-e stx))
(quote-syntax (make-rename-transformer (quote-syntax prot)))))))
(define-syntaxes (snab)
(lambda (xstx)
(datum->syntax
xstx
(list (quote-syntax define-syntaxes)
(cdr (syntax-e xstx))
(quote-syntax (make-rename-transformer (quote-syntax stx)))))))
(#%provide nab
pnab
snab)))
;; - - - - - - - - - - - - - - - - - - - -
(define two/no-protect
'(module two '#%kernel
(#%require 'one)
(define-values (normal) 10)
(nab nabbed)
(pnab pnabbed)
(snab snabbed)
(#%provide normal
nabbed
pnabbed
snabbed)))
;; - - - - - - - - - - - - - - - - - - - -
(define two/protect
'(module two '#%kernel
(#%require 'one)
(define-values (normal) 10)
(nab nabbed)
(pnab pnabbed)
(snab snabbed)
(#%provide (protect normal
nabbed
pnabbed
snabbed))))
;; - - - - - - - - - - - - - - - - - - - -
(define three/nabbed
'(module three '#%kernel
(#%module-begin
(#%require 'two)
(#%app printf "~s ~s\n"
(resolved-module-path-name
(module-path-index-resolve (car (identifier-binding (quote-syntax nabbed)))))
nabbed))))
;; - - - - - - - - - - - - - - - - - - - -
(define three/pnabbed
'(module three '#%kernel
(#%module-begin
(#%require 'two)
(#%app printf "~s ~s\n"
(resolved-module-path-name
(module-path-index-resolve (car (identifier-binding (quote-syntax pnabbed)))))
pnabbed))))
;; - - - - - - - - - - - - - - - - - - - -
(define three/snabbed
'(module three '#%kernel
(#%module-begin
(#%require 'two)
(#%app printf "~s ~s\n"
(resolved-module-path-name
(module-path-index-resolve (car (identifier-binding (quote-syntax snabbed)))))
snabbed))))
;; - - - - - - - - - - - - - - - - - - - -
(define three/normal
'(module three '#%kernel
(#%module-begin
(#%require 'two)
(#%app printf "~s ~s\n"
(resolved-module-path-name
(module-path-index-resolve (car (identifier-binding (quote-syntax normal)))))
normal))))
;; - - - - - - - - - - - - - - - - - - - -
(define (xeval e)
(eval
(if (bytes? e)
(parameterize ([read-accept-compiled #t])
(read (open-input-bytes e)))
e)))
(define (mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal
get-one-inspector get-three-inspector fail-pnab? fail-prot? fail-three? np-ok?)
(let ([try
(lambda (two three v)
(let ([ns (make-base-namespace)]
[p (open-output-bytes)])
(parameterize ([current-namespace ns]
[current-output-port p])
(xeval zero)
(parameterize ([current-code-inspector (get-one-inspector)])
(xeval one)
(xeval two)
(parameterize ([current-code-inspector (get-three-inspector)])
(with-handlers ([(lambda (x) fail-three?)
(lambda (exn)
(printf "~a\n" (exn-message exn)))])
(xeval three))
(with-handlers ([values (lambda (exn)
(printf "~a\n" (exn-message exn)))])
(eval '(#%require 'three))))))
(test #t regexp-match?
(if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v))))
(get-output-bytes p))))])
(try two/no-protect three/nabbed (if (and fail-prot? (not np-ok?)) #rx#"unexported .* unexp" #rx#"one 5"))
(try two/no-protect three/pnabbed (if (and fail-pnab? (not np-ok?)) #rx#"protected .* prot" #rx#"zero 8"))
(try two/no-protect three/snabbed #rx#"one 13")
(try two/no-protect three/normal #rx#"two 10")
(try two/protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one 5"))
(try two/protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero 8"))
(try two/protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one 13"))
(try two/protect three/normal (if fail-prot? #rx#"protected .* normal" #rx#"two 10"))))
;; - - - - - - - - - - - - - - - - - - - -
(define-values (zero-zo one-zo two/no-protect-zo two/protect-zo
three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo)
(apply
values
(let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns])
(map (lambda (c)
(let ([c (compile c)]
[p (open-output-bytes)])
(write c p)
(eval c)
(get-output-bytes p)))
(list zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal))))))
;; - - - - - - - - - - - - - - - - - - - -
(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal
current-code-inspector current-code-inspector #f #f #f #f)
(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo
current-code-inspector current-code-inspector #f #f #f #f)
(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo
make-inspector current-code-inspector #t #f #f #f)
(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed-zo three/normal
make-inspector current-code-inspector #t #f #t #f)
(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo
current-code-inspector make-inspector #t #t #f #f)
(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal
current-code-inspector make-inspector #t #t #t #t)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

1
collects/tests/mzscheme/mz-tests.ss
View File

@ -23,6 +23,7 @@
(load-relative "prompt.ss")
(load-relative "will.ss")
(load-relative "namespac.ss")
(load-relative "modprot.ss")
(unless (or building-flat-tests? in-drscheme?)
(load-relative "param.ss"))
(load-relative "port.ss")

2
collects/tests/r6rs/syntax-case.sls
View File

@ -216,7 +216,7 @@
(test (bound-identifier=? #'cons #'kons) #f)
(test (free-identifier=? #'x #'x) #t)
(test (free-identifier=? #'x #'y) #f)
(test (free-identifier=? #'cons #'kons) #t)
;; (test (free-identifier=? #'cons #'kons) #t) ;; see PLT bug report #10210
(test (syntax->datum #'1) 1)
(test (syntax->datum #'a) 'a)

2
collects/tests/run-automated-tests.ss
View File

@ -33,7 +33,7 @@
(define tests
'([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")]
;; [require "planet/lang.ss"]
[require "typed-scheme/run.ss"]
;; [require "typed-scheme/run.ss"]
[require "match/plt-match-tests.ss"]
;; [require "stepper/automatic-tests.ss" (lib "scheme/base")]
[require "lazy/main.ss"]

6
collects/tests/typed-scheme/succeed/for-lists.ss Normal file
View File

@ -0,0 +1,6 @@
#lang typed-scheme
(: f ((Listof Number) -> (Listof Number)))
(define (f x)
(for/lists (#{y : (Listof Number)}) ([e (in-list x)])
e))

9
collects/tests/typed-scheme/succeed/match-tests.ss Normal file
View File

@ -0,0 +1,9 @@
#lang typed-scheme
(require scheme/match)
(match "abc"
[(regexp "^abc") 1])
(match (list 1 1)
[(list x x) 1])

18
collects/tests/typed-scheme/unit-tests/typecheck-tests.ss
View File

@ -87,7 +87,7 @@
(+ 1 (car x))
5))
N]
(tc-e (if (let ([y 12]) y) 3 4) -Integer)
(tc-e 3 -Integer)
(tc-e "foo" -String)
(tc-e (+ 3 4) -Integer)
@ -496,10 +496,10 @@
[tc-e (raise-type-error 'foo "bar" 7 (list 5)) (Un)]
#;[tc-e
(let ((x '(1 3 5 7 9)))
(do: : Number ((x : (list-of Number) x (cdr x))
(sum : Number 0 (+ sum (car x))))
((null? x) sum)))
(let ((x '(1 3 5 7 9)))
(do: : Number ((x : (list-of Number) x (cdr x))
(sum : Number 0 (+ sum (car x))))
((null? x) sum)))
N]
@ -541,10 +541,10 @@
[tc-e `(4 ,@'(3)) (-pair N (-lst N))]
[tc-e
(let ((x '(1 3 5 7 9)))
(do: : Number ((x : (Listof Number) x (cdr x))
(sum : Number 0 (+ sum (car x))))
((null? x) sum)))
(let ((x '(1 3 5 7 9)))
(do: : Number ((x : (Listof Number) x (cdr x))
(sum : Number 0 (+ sum (car x))))
((null? x) sum)))
N]
[tc-e (if #f 1 'foo) (-val 'foo)]

2
collects/web-server/scribblings/servlet-env.scrbl
View File

@ -120,7 +120,7 @@ and if @scheme[serve/servlet] is run in another module.
(regexp-quote servlet-path)))]
[#:stateless? stateless? boolean? #f]
[#:stuffer stuffer (stuffer/c serializable? bytes?) default-stuffer]
[#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))]
[#:manager manager manager? (make-threshold-LRU-manager #f (* 128 1024 1024))]
[#:servlet-namespace servlet-namespace (listof module-path?) empty]
[#:server-root-path server-root-path path-string? default-server-root-path]
[#:extra-files-paths extra-files-paths (listof path-string?) (list (build-path server-root-path "htdocs"))]

2
collects/web-server/servlet-env.ss
View File

@ -94,7 +94,7 @@
(lambda (request)
`(html (head (title "Page Has Expired."))
(body (p "Sorry, this page has expired. Please go back."))))
(* 64 1024 1024))]
(* 128 1024 1024))]
#:servlet-path
[servlet-path "/servlets/standalone.ss"]

153
src/mred/mred.cxx
View File

@ -1743,7 +1743,7 @@ static void MrEdSleep(float secs, void *fds)
}
#ifdef wx_msw
MrEdMSWSleep(secs, fds);
MrEdMSWSleep(secs, fds, mzsleep);
#else
# ifdef wx_mac
MrEdMacSleep(secs, fds, mzsleep);
@ -2214,6 +2214,44 @@ static Scheme_Object *stdin_pipe;
#if WCONSOLE_STDIO
static HANDLE console_out;
static HANDLE console_in;
static Scheme_Object *console_inport;
static HWND console_hwnd;
static int has_stdio, stdio_kills_prog;
static HANDLE waiting_sema;
typedef HWND (WINAPI* gcw_proc)();
static BOOL WINAPI ConsoleHandler(DWORD op)
{
if (stdio_kills_prog) {
ReleaseSemaphore(waiting_sema, 1, NULL);
} else {
scheme_break_main_thread();
scheme_signal_received();
}
return TRUE;
}
static void WaitOnConsole()
{
DWORD wrote;
stdio_kills_prog = 1;
if (console_hwnd) {
AppendMenu(GetSystemMenu(console_hwnd, FALSE),
MF_STRING,
SC_CLOSE,
"Close");
/* Un-gray the close box: */
RedrawWindow(console_hwnd, NULL, NULL,
RDW_FRAME | RDW_INVALIDATE | RDW_UPDATENOW);
}
WriteConsole(console_out, "\n[Exited. Close box or Ctrl-C closes the console.]\n", 51, &wrote, NULL);
WaitForSingleObject(waiting_sema, INFINITE);
}
#else /* !WCONSOLE_STDIO */
@ -2238,6 +2276,33 @@ static void MrEdSchemeMessages(char *msg, ...)
if (!console_out) {
AllocConsole();
console_out = GetStdHandle(STD_OUTPUT_HANDLE);
console_in = GetStdHandle(STD_INPUT_HANDLE);
has_stdio = 1;
waiting_sema = CreateSemaphore(NULL, 0, 1, NULL);
SetConsoleCtrlHandler(ConsoleHandler, TRUE);
wxREGGLOB(console_inport);
console_inport = scheme_make_fd_input_port((int)console_in, scheme_intern_symbol("stdin"), 0, 0);
{
HMODULE hm;
gcw_proc gcw;
hm = LoadLibrary("kernel32.dll");
if (hm)
gcw = (gcw_proc)GetProcAddress(hm, "GetConsoleWindow");
else
gcw = NULL;
if (gcw)
console_hwnd = gcw();
}
if (console_hwnd) {
EnableMenuItem(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE,
MF_BYCOMMAND | MF_GRAYED);
RemoveMenu(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, MF_BYCOMMAND);
}
}
#endif
#if REDIRECT_STDIO
@ -2253,18 +2318,21 @@ static void MrEdSchemeMessages(char *msg, ...)
#if WCONSOLE_STDIO
if (!msg) {
char *s;
long l;
DWORD wrote;
long l, d;
DWORD wrote;
s = va_arg(args, char*);
d = va_arg(args, long);
l = va_arg(args, long);
WriteConsole(console_out, s, l, &wrote, NULL);
WriteConsole(console_out, s XFORM_OK_PLUS d, l, &wrote, NULL);
} else {
char buffer[2048];
char *buffer;
DWORD wrote;
buffer = (char *)malloc(5 * strlen(msg));
vsprintf(buffer, msg, args);
WriteConsole(console_out, buffer, strlen(buffer), &wrote, NULL);
free(buffer);
}
#endif
#if !WCONSOLE_STDIO
@ -2345,22 +2413,64 @@ static long mrconsole_get_string(Scheme_Input_Port *ip,
Scheme_Object *pipe = (Scheme_Object *)ip->port_data;
MrEdSchemeMessages("");
#if WCONSOLE_STDIO
pipe = console_inport;
#endif
add_console_reading();
result = scheme_get_byte_string("console get-string", pipe, buffer, offset, size, nonblock ? 2 : 0, 0, 0);
result = scheme_get_byte_string_unless("console get-string", pipe,
buffer, offset, size,
nonblock, 0, NULL,
unless);
remove_console_reading();
return result;
}
static Scheme_Object *mrconsole_progress_evt(Scheme_Input_Port *ip)
{
Scheme_Object *pipe = (Scheme_Object *)ip->port_data;
MrEdSchemeMessages("");
#if WCONSOLE_STDIO
pipe = console_inport;
#endif
return scheme_progress_evt(pipe);
}
static int mrconsole_peeked_read(Scheme_Input_Port *ip,
long amount,
Scheme_Object *unless,
Scheme_Object *target_ch)
{
Scheme_Object *pipe = (Scheme_Object *)ip->port_data;
MrEdSchemeMessages("");
#if WCONSOLE_STDIO
pipe = console_inport;
#endif
return scheme_peeked_read(pipe, amount, unless, target_ch);
}
static int mrconsole_char_ready(Scheme_Input_Port *ip)
{
Scheme_Object *pipe = (Scheme_Object *)ip->port_data;
MrEdSchemeMessages("");
#if WCONSOLE_STDIO
pipe = console_inport;
#endif
return scheme_char_ready(pipe);
}
static void mrconsole_close(Scheme_Input_Port *ip)
{
Scheme_Object *pipe = (Scheme_Object *)ip->port_data;
#if WCONSOLE_STDIO
pipe = console_inport;
#endif
scheme_close_input_port(pipe);
}
@ -2378,8 +2488,8 @@ static Scheme_Object *MrEdMakeStdIn(void)
scheme_intern_symbol("mred-console"),
CAST_GS mrconsole_get_string,
NULL,
scheme_progress_evt_via_get,
scheme_peeked_read_via_get,
mrconsole_progress_evt,
mrconsole_peeked_read,
CAST_IREADY mrconsole_char_ready,
CAST_ICLOSE mrconsole_close,
NULL,
@ -2898,6 +3008,20 @@ static Scheme_Env *setup_basic_env()
return global_env;
}
#if WCONSOLE_STDIO
static void MrEdExit(int v)
{
if (has_stdio) {
WaitOnConsole();
}
#ifdef wx_msw
mred_clean_up_gdi_objects();
#endif
scheme_immediate_exit(v);
}
#endif
wxFrame *MrEdApp::OnInit(void)
{
MrEdContext *mmc;
@ -3027,6 +3151,15 @@ wxFrame *MrEdApp::OnInit(void)
mred_run_from_cmd_line(argc, argv, setup_basic_env);
#if WCONSOLE_STDIO
if (!wx_in_terminal) {
/* The only reason we get here is that a command-line error or
-h occured. In either case, stick around for the sake of the
console. */
MrEdExit(1);
}
#endif
return NULL;
}
@ -3052,6 +3185,10 @@ void MrEdApp::RealInit(void)
initialized = 1;
thread->on_kill = CAST_TOK on_main_killed;
#if WCONSOLE_STDIO
if (!wx_in_terminal)
scheme_exit = CAST_EXIT MrEdExit;
#endif
#ifdef wx_xt
if (wx_single_instance) {

2
src/mred/mred.h
View File

@ -110,7 +110,7 @@ extern "C" {
}
#ifdef wx_msw
void MrEdMSWSleep(float secs, void *fds);
void MrEdMSWSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep);
MRED_EXTERN void mred_clean_up_gdi_objects(void);
#endif

28
src/mred/mredmsw.cxx
View File

@ -845,7 +845,7 @@ int MrEdCheckForBreak(void)
}
}
void MrEdMSWSleep(float secs, void *fds)
void MrEdMSWSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep)
{
DWORD msecs;
@ -909,30 +909,8 @@ void MrEdMSWSleep(float secs, void *fds)
}
if (fds) {
win_extended_fd_set *r;
int num_handles, num_rhandles, *rps, result;
HANDLE *handles;
scheme_collapse_win_fd(fds); /* merges */
r = (win_extended_fd_set *)fds;
num_rhandles = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->num_handles);
num_handles = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->combined_len);
handles = ((win_extended_fd_set *)fds)->combined_wait_array;
rps = ((win_extended_fd_set *)fds)->repost_sema;
result = MsgWaitForMultipleObjects(num_handles, handles, FALSE,
secs ? msecs : INFINITE,
QS_ALLINPUT);
if ((result >= WAIT_OBJECT_0) && (result < WAIT_OBJECT_0 + num_rhandles)) {
result -= WAIT_OBJECT_0;
if (rps[result])
ReleaseSemaphore(handles[result], 1, NULL);
}
scheme_collapse_win_fd(fds); /* cleans up */
scheme_add_fd_eventmask(fds, QS_ALLINPUT);
mzsleep(secs, fds);
} else if (wxTheApp->keep_going) {
MsgWaitForMultipleObjects(0, NULL, FALSE,
secs ? msecs : INFINITE,

2
src/mzscheme/gc2/Makefile.in
View File

@ -132,7 +132,7 @@ xsrc:
xobjects: $(OBJS) main.@LTO@
XFORMDEP = $(srcdir)/gc2.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss \
XFORMDEP = $(srcdir)/gc2.h $(srcdir)/gc2_obj.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss \
$(srcdir)/precomp.c $(srcdir)/../src/schpriv.h $(srcdir)/../include/scheme.h \
$(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schemef.h \
$(srcdir)/../src/stypes.h

44
src/mzscheme/gc2/mem_account.c
View File

@ -239,13 +239,26 @@ inline static unsigned long custodian_usage(NewGC*gc, void *custodian)
inline static void BTC_memory_account_mark(NewGC *gc, mpage *page, void *ptr)
{
GCDEBUG((DEBUGOUTF, "BTC_memory_account_mark: %p/%p\n", page, ptr));
if(page->big_page) {
struct objhead *info = (struct objhead *)(NUM(page->addr) + PREFIX_SIZE);
if(page->size_class) {
if(page->size_class > 1) {
/* big page */
struct objhead *info = (struct objhead *)(NUM(page->addr) + PREFIX_SIZE);
if(info->btc_mark == gc->old_btc_mark) {
info->btc_mark = gc->new_btc_mark;
account_memory(gc, gc->current_mark_owner, gcBYTES_TO_WORDS(page->size));
push_ptr(ptr);
if(info->btc_mark == gc->old_btc_mark) {
info->btc_mark = gc->new_btc_mark;
account_memory(gc, gc->current_mark_owner, gcBYTES_TO_WORDS(page->size));
push_ptr(ptr);
}
} else {
/* medium page */
struct objhead *info = MED_OBJHEAD(ptr, page->size);
if(info->btc_mark == gc->old_btc_mark) {
info->btc_mark = gc->new_btc_mark;
account_memory(gc, gc->current_mark_owner, info->size);
ptr = PTR(NUM(info) + WORD_SIZE);
push_ptr(ptr);
}
}
} else {
struct objhead *info = (struct objhead *)((char*)ptr - WORD_SIZE);
@ -315,9 +328,9 @@ int BTC_cust_box_mark(void *p)
return gc->mark_table[btc_redirect_cust_box](p);
}
inline static void mark_normal_obj(NewGC *gc, mpage *page, void *ptr)
inline static void mark_normal_obj(NewGC *gc, int type, void *ptr)
{
switch(page->page_type) {
switch(type) {
case PAGE_TAGGED: {
/* we do not want to mark the pointers in a thread or custodian
unless the object's owner is the current owner. In the case
@ -374,7 +387,6 @@ inline static void mark_acc_big_page(NewGC *gc, mpage *page)
}
}
static void btc_overmem_abort(NewGC *gc)
{
gc->kill_propagation_loop = 1;
@ -391,10 +403,16 @@ static void propagate_accounting_marks(NewGC *gc)
page = pagemap_find_page(pagemap, p);
set_backtrace_source(p, page->page_type);
GCDEBUG((DEBUGOUTF, "btc_account: popped off page %p:%p, ptr %p\n", page, page->addr, p));
if(page->big_page)
mark_acc_big_page(gc, page);
else
mark_normal_obj(gc, page, p);
if(page->size_class) {
if (page->size_class > 1)
mark_acc_big_page(gc, page);
else {
struct objhead *info = MED_OBJHEAD(p, page->size);
p = PTR(NUM(info) + WORD_SIZE);
mark_normal_obj(gc, info->type, p);
}
} else
mark_normal_obj(gc, page->page_type, p);
}
if(gc->kill_propagation_loop)
reset_pointer_stack();

705
src/mzscheme/gc2/newgc.c
View File

File diff suppressed because it is too large Load Diff

10
src/mzscheme/gc2/newgc.h
View File

@ -5,8 +5,8 @@ typedef struct mpage {
struct mpage *next;
struct mpage *prev;
void *addr;
unsigned long previous_size;
unsigned long size;
unsigned long previous_size; /* for med page, points to place to search for available block */
unsigned long size; /* big page size or med page element size */
unsigned char generation;
/*
unsigned char back_pointers :1;
@ -17,7 +17,7 @@ typedef struct mpage {
unsigned char mprotected :1;
*/
unsigned char back_pointers ;
unsigned char big_page ;
unsigned char size_class ; /* 1 => med; 2 => big; 3 => big marked */
unsigned char page_type ;
unsigned char marked_on ;
unsigned char has_new ;
@ -92,6 +92,8 @@ typedef mpage ****PageMap;
typedef mpage **PageMap;
#endif
#define NUM_MED_PAGE_SIZES (((LOG_APAGE_SIZE - 1) - 3) + 1)
typedef struct NewGC {
Gen0 gen0;
Mark_Proc *mark_table; /* the table of mark procs */
@ -101,6 +103,8 @@ typedef struct NewGC {
struct mpage *gen1_pages[PAGE_TYPES];
Page_Range *protect_range;
struct mpage *med_pages[NUM_MED_PAGE_SIZES];
struct mpage *med_freelist_pages[NUM_MED_PAGE_SIZES];
/* Finalization */
Fnl *run_queue;

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

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

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

@ -1180,6 +1180,7 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo)
env->mod_phase,
NULL,
NULL,
NULL,
0);
}
}
@ -2003,8 +2004,8 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
existing rename. */
if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) {
Scheme_Object *mod, *nm = id;
mod = scheme_stx_module_name(0, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL);
mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL);
if (mod /* must refer to env->module, otherwise there would
have been an error before getting here */
&& NOT_SAME_OBJ(nm, sym))
@ -2527,7 +2528,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0;
Scheme_Bucket *b;
Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase;
Scheme_Object *find_id_sym = NULL;
Scheme_Object *find_id_sym = NULL, *rename_insp = NULL;
Scheme_Env *genv;
long phase;
@ -2679,8 +2680,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
}
src_find_id = find_id;
modidx = scheme_stx_module_name(0, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase,
NULL, NULL, NULL, NULL);
modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase,
NULL, NULL, NULL, NULL, &rename_insp);
/* Used out of context? */
if (SAME_OBJ(modidx, scheme_undefined)) {
@ -2765,9 +2766,10 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
val = scheme_module_syntax(modname, env->genv, find_id);
if (val && !(flags & SCHEME_NO_CERT_CHECKS))
scheme_check_accessible_in_module(genv, env->insp, in_modidx,
find_id, src_find_id, certs, NULL, -2, 0,
NULL,
env->genv);
find_id, src_find_id, certs, NULL, rename_insp,
-2, 0,
NULL, NULL,
env->genv, NULL);
} else {
/* Only try syntax table if there's not an explicit (later)
variable mapping: */
@ -2790,8 +2792,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
pos = 0;
else
pos = scheme_check_accessible_in_module(genv, env->insp, in_modidx,
find_id, src_find_id, certs, NULL, -1, 1,
_protected, env->genv);
find_id, src_find_id, certs, NULL, rename_insp, -1, 1,
_protected, NULL, env->genv, NULL);
modpos = SCHEME_INT_VAL(pos);
} else
modpos = -1;
@ -2957,8 +2959,8 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok
if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) {
return 1;
} else {
mod = scheme_stx_module_name(0, &id, scheme_make_integer(env->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL);
mod = scheme_stx_module_name(NULL, &id, scheme_make_integer(env->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL);
if (SAME_OBJ(mod, scheme_undefined))
return 1;
}

13
src/mzscheme/src/error.c
View File

@ -191,6 +191,7 @@ Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config)
%Q = truncated-to-256 Scheme string
%V = scheme_value
%D = scheme value to display
%_ = skip
%L = line number, -1 means no line
%e = error number for strerror()
@ -258,6 +259,7 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch
case 'D':
case 'T':
case 'Q':
case '_':
ptrs[pp++] = mzVA_ARG(args, Scheme_Object*);
break;
default:
@ -446,6 +448,13 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch
tlen = dlen;
}
break;
case '_':
{
pp++;
t = "";
tlen = 0;
}
break;
case 'T':
case 'Q':
{
@ -1601,7 +1610,7 @@ static void do_wrong_syntax(const char *where,
phase = scheme_current_thread->current_local_env->genv->phase;
else phase = 0;
scheme_stx_module_name(0, &first, scheme_make_integer(phase), &mod, &nomwho,
NULL, NULL, NULL, NULL, NULL);
NULL, NULL, NULL, NULL, NULL, NULL);
}
}
} else {
@ -1904,7 +1913,7 @@ void scheme_unbound_global(Scheme_Bucket *b)
if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)))
errmsg = "reference to an identifier before its definition: %S in module: %D%s";
else
errmsg = "reference to an identifier before its definition: %S%s";
errmsg = "reference to an identifier before its definition: %S%_%s";
if (SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)) {
sprintf(phase_buf, " phase: %ld", SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase));

6
src/mzscheme/src/eval.c
View File

@ -1788,7 +1788,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
if (check_access && !SAME_OBJ(menv, env)) {
varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL,
insp, pos, 0, NULL, env);
insp, NULL, pos, 0, NULL, NULL, env, NULL);
}
}
@ -6090,8 +6090,8 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co
if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
/* Since the module has a rename for this id, it's certainly defined. */
} else {
modidx = scheme_stx_module_name(0, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL);
modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL);
if (modidx) {
/* If it's an access path, resolve it: */
if (env->genv->module

338
src/mzscheme/src/jit.c
View File

@ -142,6 +142,7 @@ static void *stack_cache_pop_code;
static void *struct_pred_code, *struct_pred_multi_code;
static void *struct_pred_branch_code;
static void *struct_get_code, *struct_get_multi_code;
static void *struct_set_code, *struct_set_multi_code;
static void *bad_app_vals_target;
static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code;
static void *finish_tail_call_code, *finish_tail_call_fixup_code;
@ -169,7 +170,9 @@ typedef struct {
int local1_busy;
int log_depth;
int self_pos, self_closure_size, self_toplevel_pos;
int self_to_closure_delta;
int self_to_closure_delta, closure_to_args_delta;
int example_argc;
Scheme_Object **example_argv;
void *self_restart_code;
void *self_nontail_code;
Scheme_Native_Closure *nc; /* for extract_globals and extract_closure_local, only */
@ -201,6 +204,9 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter);
static void *generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int is_tail,
int direct_prim, int direct_native, int nontail_self);
static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter,
int order_matters, int skipped);
static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_state *jitter, int stack_start);
static int lambda_has_been_jitted(Scheme_Native_Closure_Data *ndata);
@ -1485,38 +1491,51 @@ Scheme_Object *extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, i
if (pos >= jitter->self_pos - jitter->self_to_closure_delta) {
pos -= (jitter->self_pos - jitter->self_to_closure_delta);
if (pos < jitter->nc->code->u2.orig_code->closure_size) {
/* in the closure */
return jitter->nc->vals[pos];
} else {
/* maybe an example argument... which is useful when
the enclosing function has been lifted, converting
a closure element into an argument */
pos -= jitter->closure_to_args_delta;
if (pos < jitter->example_argc)
return jitter->example_argv[pos];
}
}
return NULL;
}
static int check_val_struct_prim(Scheme_Object *p)
static int check_val_struct_prim(Scheme_Object *p, int arity)
{
if (p && SCHEME_PRIMP(p)) {
if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED)
return 1;
else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
return 2;
else
return 0;
} else
return 0;
if (arity == 1) {
if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED)
return 1;
else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
return 2;
} else if (arity == 2) {
if ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER)
&& ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK)
== SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER))
return 3;
}
}
return 0;
}
static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int extra_push)
static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int extra_push, int arity)
{
if (jitter->nc) {
if (SAME_TYPE(SCHEME_TYPE(o), scheme_toplevel_type)) {
Scheme_Object *p;
p = extract_global(o, jitter->nc);
p = ((Scheme_Bucket *)p)->val;
return check_val_struct_prim(p);
return check_val_struct_prim(p, arity);
} else if (SAME_TYPE(SCHEME_TYPE(o), scheme_local_type)) {
Scheme_Object *p;
p = extract_closure_local(o, jitter, extra_push);
return check_val_struct_prim(p);
return check_val_struct_prim(p, arity);
}
}
return 0;
@ -1528,23 +1547,24 @@ static int inlined_unary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_stat
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_UNARY_INLINED))
return 1;
if (inlineable_struct_prim(o, jitter, 1))
if (inlineable_struct_prim(o, jitter, 1, 1))
return 1;
return 0;
}
static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app)
static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_state *jitter)
{
return (SCHEME_PRIMP(o)
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED));
return ((SCHEME_PRIMP(o)
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED))
|| inlineable_struct_prim(o, jitter, 2, 2));
}
static int inlined_nary_prim(Scheme_Object *o, Scheme_Object *_app)
{
return (SCHEME_PRIMP(o)
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_NARY_INLINED)
&& (((Scheme_App_Rec *)_app)->num_args >= ((Scheme_Primitive_Proc *)o)->mina)
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_NARY_INLINED)
&& (((Scheme_App_Rec *)_app)->num_args >= ((Scheme_Primitive_Proc *)o)->mina)
&& (((Scheme_App_Rec *)_app)->num_args <= ((Scheme_Primitive_Proc *)o)->mu.maxa));
}
@ -1670,7 +1690,7 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st
}
break;
case scheme_application3_type:
if (inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj))
if (inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter))
return 1;
else if (just_markless) {
return is_noncm(((Scheme_App3_Rec *)obj)->rator, jitter, depth, stack_start + 2);
@ -2603,7 +2623,9 @@ static int can_direct_native(Scheme_Object *p, int num_rands, long *extract_case
static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands,
mz_jit_state *jitter, int is_tail, int multi_ok, int no_call)
/* de-sync'd ok */
/* de-sync'd ok
If no_call is 2, then rator is not necssarily evaluated.
If no_call is 1, then rator is left in V1 and arguments are on runstack. */
{
int i, offset, need_safety = 0;
int direct_prim = 0, need_non_tail = 0, direct_native = 0, direct_self = 0, nontail_self = 0;
@ -2840,13 +2862,14 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
}
if (reorder_ok) {
if (!no_call) {
generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below */
if (no_call < 2) {
generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below, or not */
}
CHECK_LIMIT();
}
mz_rs_sync();
if (!no_call)
mz_rs_sync();
END_JIT_DATA(20);
@ -3893,42 +3916,33 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
}
static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
Scheme_Object *rator, Scheme_Object *rand,
Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2,
jit_insn **for_branch, int branch_short,
int multi_ok)
/* de-sync'd ok; for branch, sync'd before */
{
mz_runstack_skipped(jitter, 1);
LOG_IT(("inlined struct op\n"));
generate(rator, jitter, 0, 0, JIT_R0); /* sync'd below */
CHECK_LIMIT();
if (SAME_TYPE(scheme_local_type, SCHEME_TYPE(rand))) {
jit_movr_p(JIT_R1, JIT_R0);
generate(rand, jitter, 0, 0, JIT_R0); /* sync'd below */
mz_runstack_unskipped(jitter, 1);
if (!rand2) {
generate_two_args(rator, rand, jitter, 1, 1); /* sync'd below */
CHECK_LIMIT();
} else {
mz_runstack_unskipped(jitter, 1);
mz_rs_dec(1);
CHECK_RUNSTACK_OVERFLOW();
mz_runstack_pushed(jitter, 1);
mz_rs_str(JIT_R0);
Scheme_Object *args[3];
args[0] = rator;
args[1] = rand;
args[2] = rand2;
generate_app(NULL, args, 2, jitter, 0, 0, 1); /* sync'd below */
CHECK_LIMIT();
generate_non_tail(rand, jitter, 0, 1); /* sync'd below */
CHECK_LIMIT();
jit_movr_p(JIT_R0, JIT_V1);
mz_rs_ldr(JIT_R1);
mz_rs_inc(1);
mz_runstack_popped(jitter, 1);
mz_rs_ldxi(JIT_V1, 1);
mz_rs_inc(2); /* sync'd below */
mz_runstack_popped(jitter, 2);
}
mz_rs_sync();
/* R1 is [potential] predicate/getter, R0 is value */
/* R0 is [potential] predicate/getter/setting, R1 is struct.
V1 is value for setting. */
if (for_branch) {
for_branch[2] = jit_patchable_movi_p(JIT_V1, jit_forward());
@ -3939,12 +3953,18 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
} else {
(void)jit_calli(struct_pred_code);
}
} else {
} else if (kind == 2) {
if (multi_ok) {
(void)jit_calli(struct_get_multi_code);
} else {
(void)jit_calli(struct_get_code);
}
} else {
if (multi_ok) {
(void)jit_calli(struct_set_multi_code);
} else {
(void)jit_calli(struct_set_code);
}
}
return 1;
@ -3962,13 +3982,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
{
int k;
k = inlineable_struct_prim(rator, jitter, 1);
k = inlineable_struct_prim(rator, jitter, 1, 1);
if (k == 1) {
generate_inlined_struct_op(1, jitter, rator, app->rand, for_branch, branch_short, multi_ok);
generate_inlined_struct_op(1, jitter, rator, app->rand, NULL, for_branch, branch_short, multi_ok);
scheme_direct_call_count++;
return 1;
} else if ((k == 2) && !for_branch) {
generate_inlined_struct_op(2, jitter, rator, app->rand, for_branch, branch_short, multi_ok);
generate_inlined_struct_op(2, jitter, rator, app->rand, NULL, for_branch, branch_short, multi_ok);
scheme_direct_call_count++;
return 1;
}
@ -4377,7 +4397,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
return 0;
}
static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, int order_matters)
static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter,
int order_matters, int skipped)
/* de-sync's rs.
Results go into R0 and R1. If !order_matters, and if only the
second is simple, then the arguments will be in reverse order. */
@ -4389,7 +4410,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
if (!simple1) {
if (simple2) {
mz_runstack_skipped(jitter, 2);
mz_runstack_skipped(jitter, skipped);
generate_non_tail(rand1, jitter, 0, 1); /* no sync... */
CHECK_LIMIT();
@ -4406,18 +4427,18 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
} else
direction = -1;
mz_runstack_unskipped(jitter, 2);
mz_runstack_unskipped(jitter, skipped);
} else {
mz_runstack_skipped(jitter, 2);
mz_runstack_skipped(jitter, skipped);
generate_non_tail(rand1, jitter, 0, 1); /* no sync... */
CHECK_LIMIT();
mz_runstack_unskipped(jitter, 2);
mz_runstack_unskipped(jitter, skipped);
mz_rs_dec(1);
CHECK_RUNSTACK_OVERFLOW();
mz_runstack_pushed(jitter, 1);
mz_rs_str(JIT_R0);
mz_runstack_skipped(jitter, 1);
mz_runstack_skipped(jitter, skipped-1);
generate_non_tail(rand2, jitter, 0, 1); /* no sync... */
CHECK_LIMIT();
@ -4425,12 +4446,12 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
jit_movr_p(JIT_R1, JIT_R0);
mz_rs_ldr(JIT_R0);
mz_runstack_unskipped(jitter, 1);
mz_runstack_unskipped(jitter, skipped-1);
mz_rs_inc(1);
mz_runstack_popped(jitter, 1);
}
} else {
mz_runstack_skipped(jitter, 2);
mz_runstack_skipped(jitter, skipped);
if (simple2) {
generate(rand2, jitter, 0, 0, JIT_R1); /* no sync... */
@ -4444,7 +4465,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
generate(rand1, jitter, 0, 0, JIT_R0); /* no sync... */
CHECK_LIMIT();
mz_runstack_unskipped(jitter, 2);
mz_runstack_unskipped(jitter, skipped);
}
return direction;
@ -4462,7 +4483,7 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
r1 = app->rand1;
r2 = app->rand2;
direction = generate_two_args(r1, r2, jitter, 1);
direction = generate_two_args(r1, r2, jitter, 1, 2);
CHECK_LIMIT();
mz_rs_sync();
@ -4604,6 +4625,14 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
{
Scheme_Object *rator = app->rator;
if (!for_branch
&& inlineable_struct_prim(rator, jitter, 2, 2)) {
generate_inlined_struct_op(3, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, multi_ok);
scheme_direct_call_count++;
return 1;
}
if (!SCHEME_PRIMP(rator))
return 0;
@ -4669,7 +4698,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
__END_SHORT_JUMPS__(branch_short);
} else {
/* Two complex expressions: */
generate_two_args(a2, a1, jitter, 0);
generate_two_args(a2, a1, jitter, 0, 2);
CHECK_LIMIT();
mz_rs_sync();
@ -4762,7 +4791,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
&& (SCHEME_INT_VAL(app->rand2) >= 0));
if (!simple) {
generate_two_args(app->rand1, app->rand2, jitter, 1);
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
mz_rs_sync();
@ -4816,7 +4845,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
LOG_IT(("inlined set-mcar!\n"));
generate_two_args(app->rand1, app->rand2, jitter, 1);
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
mz_rs_sync();
@ -4847,7 +4876,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|| IS_NAMED_PRIM(rator, "list*")) {
LOG_IT(("inlined cons\n"));
generate_two_args(app->rand1, app->rand2, jitter, 1);
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
mz_rs_sync();
@ -4855,7 +4884,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} else if (IS_NAMED_PRIM(rator, "mcons")) {
LOG_IT(("inlined mcons\n"));
generate_two_args(app->rand1, app->rand2, jitter, 1);
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
mz_rs_sync();
@ -4881,7 +4910,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} else if (IS_NAMED_PRIM(rator, "list")) {
LOG_IT(("inlined list\n"));
generate_two_args(app->rand1, app->rand2, jitter, 1);
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
mz_rs_dec(1);
@ -5054,7 +5083,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
star = IS_NAMED_PRIM(rator, "list*");
if (c)
generate_app(app, NULL, c, jitter, 0, 0, 1);
generate_app(app, NULL, c, jitter, 0, 0, 2);
CHECK_LIMIT();
mz_rs_sync();
@ -5145,12 +5174,12 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator,
mz_runstack_unskipped(jitter, 1);
c = 1;
} else if (app3) {
generate_two_args(app3->rand1, app3->rand2, jitter, 1); /* sync'd below */
generate_two_args(app3->rand1, app3->rand2, jitter, 1, 2); /* sync'd below */
c = 2;
} else {
c = app->num_args;
if (c)
generate_app(app, NULL, c, jitter, 0, 0, 1); /* sync'd below */
generate_app(app, NULL, c, jitter, 0, 0, 2); /* sync'd below */
}
CHECK_LIMIT();
@ -6652,6 +6681,36 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
return cnt;
}
static int save_struct_temp(mz_jit_state *jitter)
{
#ifdef MZ_USE_JIT_PPC
jit_movr_p(JIT_V(3), JIT_V1);
#endif
#ifdef MZ_USE_JIT_I386
# ifdef X86_ALIGN_STACK
mz_set_local_p(JIT_V1, JIT_LOCAL3);
# else
jit_pushr_p(JIT_V1);
# endif
#endif
return 1;
}
static int restore_struct_temp(mz_jit_state *jitter, int reg)
{
#ifdef MZ_USE_JIT_PPC
jit_movr_p(reg, JIT_V(3));
#endif
#ifdef MZ_USE_JIT_I386
# ifdef X86_ALIGN_STACK
mz_get_local_p(reg, JIT_LOCAL3);
# else
jit_popr_p(reg);
# endif
#endif
return 1;
}
static int do_generate_common(mz_jit_state *jitter, void *_data)
{
int in, i, ii, iii;
@ -7399,11 +7458,12 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
__END_TINY_JUMPS__(1);
}
/* *** struct_{pred,get}[_branch]_code *** */
/* R1 is (potential) struct proc, R0 is (potential) struct */
/* In branch mode, V1 is target address for false branch */
/* *** struct_{pred,get,set}[_branch]_code *** */
/* R0 is (potential) struct proc, R1 is (potential) struct. */
/* In branch mode, V1 is target address for false branch. */
/* In set mode, V1 is value to install. */
for (ii = 0; ii < 2; ii++) {
for (i = 0; i < 3; i++) {
for (i = 0; i < 4; i++) {
void *code, *code_end;
int kind, for_branch;
jit_insn *ref, *ref2, *refslow, *bref1, *bref2, *bref3, *bref4, *bref5, *bref6, *bref8;
@ -7424,44 +7484,48 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
for_branch = 1;
struct_pred_branch_code = jit_get_ip().ptr;
/* Save target address for false branch: */
#ifdef MZ_USE_JIT_PPC
jit_movr_p(JIT_V(3), JIT_V1);
#endif
#ifdef MZ_USE_JIT_I386
# ifdef X86_ALIGN_STACK
mz_set_local_p(JIT_V1, JIT_LOCAL3);
# else
jit_pushr_p(JIT_V1);
# endif
#endif
} else {
save_struct_temp(jitter);
} else if (i == 2) {
kind = 2;
for_branch = 0;
if (ii == 1)
struct_get_multi_code = jit_get_ip().ptr;
else
struct_get_code = jit_get_ip().ptr;
} else {
kind = 3;
for_branch = 0;
if (ii == 1)
struct_set_multi_code = jit_get_ip().ptr;
else
struct_set_code = jit_get_ip().ptr;
/* Save value to install: */
save_struct_temp(jitter);
}
mz_prolog(JIT_V1);
__START_SHORT_JUMPS__(1);
ref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
CHECK_LIMIT();
/* Slow path: non-struct proc, or argument type is
bad for a getter. */
refslow = _jit.x.pc;
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES((kind == 3) ? 2 : 1));
CHECK_RUNSTACK_OVERFLOW();
JIT_UPDATE_THREAD_RSPTR();
jit_str_p(JIT_RUNSTACK, JIT_R0);
jit_movi_i(JIT_V1, 1);
jit_str_p(JIT_RUNSTACK, JIT_R1);
if (kind == 3) {
restore_struct_temp(jitter, JIT_V1);
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_V1);
}
jit_movi_i(JIT_V1, ((kind == 3) ? 2 : 1));
jit_prepare(3);
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_p(JIT_V1);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_R0);
if (ii == 1) {
(void)mz_finish(_scheme_apply_multi_from_native);
} else {
@ -7469,7 +7533,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
}
jit_retval(JIT_R0);
VALIDATE_RESULT(JIT_R0);
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES((kind == 3) ? 2 : 1));
JIT_UPDATE_THREAD_RSPTR();
if (!for_branch) {
mz_epilog(JIT_V1);
@ -7484,24 +7548,29 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* Continue trying fast path: check proc */
mz_patch_branch(ref);
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(refslow, JIT_R2, scheme_prim_type);
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Primitive_Proc *)0x0)->pp.flags);
(void)jit_bmci_i(refslow, JIT_R2, ((kind == 1)
? SCHEME_PRIM_IS_STRUCT_PRED
: SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER));
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags);
if (kind == 3) {
jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK);
(void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER);
} else {
(void)jit_bmci_i(refslow, JIT_R2, ((kind == 1)
? SCHEME_PRIM_IS_STRUCT_PRED
: SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER));
}
CHECK_LIMIT();
/* Check argument: */
if (kind == 1) {
bref1 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1);
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
__START_INNER_TINY__(1);
ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type);
__END_INNER_TINY__(1);
bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_struct_type);
} else {
(void)jit_bmsi_ul(refslow, JIT_R0, 0x1);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
(void)jit_bmsi_ul(refslow, JIT_R1, 0x1);
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
__START_INNER_TINY__(1);
ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type);
__END_INNER_TINY__(1);
@ -7514,15 +7583,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
CHECK_LIMIT();
/* Put argument struct type in R2, target struct type in V1 */
jit_ldxi_p(JIT_R2, JIT_R0, &((Scheme_Structure *)0x0)->stype);
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
if (kind == 2) {
jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype);
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val);
if (kind >= 2) {
jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type);
}
CHECK_LIMIT();
/* common case: types are the same */
if (kind == 2) {
if (kind >= 2) {
__START_INNER_TINY__(1);
bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1);
__END_INNER_TINY__(1);
@ -7542,13 +7611,13 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* Lookup argument type at target type depth, put it in R2: */
jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE);
jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types);
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Structure *)0x0)->stype);
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Structure *)0x0)->stype);
jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2);
CHECK_LIMIT();
/* Re-load target type into V1: */
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
if (kind == 2) {
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val);
if (kind >= 2) {
jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type);
}
@ -7575,16 +7644,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
mz_patch_branch(bref4);
if (for_branch) {
mz_patch_branch(bref5);
#ifdef MZ_USE_JIT_PPC
jit_movr_p(JIT_V1, JIT_V(3));
#endif
#ifdef MZ_USE_JIT_I386
# ifdef X86_ALIGN_STACK
mz_get_local_p(JIT_V1, JIT_LOCAL3);
# else
jit_popr_p(JIT_V1);
# endif
#endif
restore_struct_temp(jitter, JIT_V1);
mz_epilog_without_jmp();
jit_jmpr(JIT_V1);
} else {
@ -7598,11 +7658,17 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
mz_patch_branch(bref8);
__END_INNER_TINY__(1);
/* Extract field */
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val);
jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field);
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots);
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
if (kind == 3) {
restore_struct_temp(jitter, JIT_R0);
jit_stxr_p(JIT_V1, JIT_R1, JIT_R0);
(void)jit_movi_p(JIT_R0, scheme_void);
} else {
jit_ldxr_p(JIT_R0, JIT_R1, JIT_V1);
}
mz_epilog(JIT_V1);
}
CHECK_LIMIT();
@ -7718,6 +7784,8 @@ typedef struct {
void *arity_code, *code, *tail_code, *code_end, **patch_depth;
int max_extra, max_depth;
Scheme_Native_Closure *nc;
int argc;
Scheme_Object **argv;
} Generate_Closure_Data;
static int do_generate_closure(mz_jit_state *jitter, void *_data)
@ -7725,12 +7793,16 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
Generate_Closure_Data *gdata = (Generate_Closure_Data *)_data;
Scheme_Closure_Data *data = gdata->data;
void *code, *tail_code, *code_end, *arity_code;
int i, r, cnt, has_rest, is_method, num_params;
int i, r, cnt, has_rest, is_method, num_params, to_args, argc;
Scheme_Object **argv;
code = jit_get_ip().ptr;
jitter->nc = gdata->nc;
argc = gdata->argc;
argv = gdata->argv;
generate_function_prolog(jitter, code,
/* max_extra_pushed may be wrong the first time around,
but it will be right the last time around */
@ -7836,18 +7908,31 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
__END_SHORT_JUMPS__(cnt < 100);
has_rest = 1;
} else
if (argc < (data->num_params - 1)) {
argv = NULL;
argc = 0;
}
} else {
has_rest = 0;
if (argc != data->num_params) {
argv = NULL;
argc = 0;
}
}
#ifdef JIT_PRECISE_GC
/* Keeping the native-closure pointer on the runstack
ensures that the code won't be GCed while we're running
it. */
mz_pushr_p(JIT_R0); /* no sync */
to_args = 0;
#else
to_args = 0;
#endif
/* Extract closure to runstack: */
cnt = data->closure_size;
to_args += cnt;
if (cnt) {
mz_rs_dec(cnt);
CHECK_RUNSTACK_OVERFLOW();
@ -7915,6 +8000,9 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
jitter->self_nontail_code = tail_code;
jitter->self_to_closure_delta = jitter->self_pos;
jitter->closure_to_args_delta = to_args;
jitter->example_argc = argc;
jitter->example_argv = argv;
/* Generate code for the body: */
jitter->need_set_rs = 1;
@ -7945,7 +8033,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
return 1;
}
static void on_demand_generate_lambda(Scheme_Native_Closure *nc)
static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv)
{
Scheme_Native_Closure_Data *ndata = nc->code;
Scheme_Closure_Data *data;
@ -7957,6 +8045,8 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc)
gdata.data = data;
gdata.nc = nc;
gdata.argc = argc;
gdata.argv = argv;
scheme_delay_load_closure(data);
@ -8024,7 +8114,7 @@ static void on_demand()
argc = MZ_RUNSTACK[1];
argv = (Scheme_Object **)MZ_RUNSTACK[2];
on_demand_generate_lambda((Scheme_Native_Closure *)c);
on_demand_generate_lambda((Scheme_Native_Closure *)c, SCHEME_INT_VAL(argc), argv);
}
Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, int clear_code_after_jit,

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

File diff suppressed because it is too large Load Diff

38
src/mzscheme/src/mzmark.c
View File

@ -2465,6 +2465,7 @@ static int module_phase_exports_val_MARK(void *p) {
gcMARK(m->provide_src_names);
gcMARK(m->provide_nominal_srcs);
gcMARK(m->provide_src_phases);
gcMARK(m->provide_insps);
gcMARK(m->kernel_exclusion);
gcMARK(m->kernel_exclusion2);
@ -2487,6 +2488,7 @@ static int module_phase_exports_val_FIXUP(void *p) {
gcFIXUP(m->provide_src_names);
gcFIXUP(m->provide_nominal_srcs);
gcFIXUP(m->provide_src_phases);
gcFIXUP(m->provide_insps);
gcFIXUP(m->kernel_exclusion);
gcFIXUP(m->kernel_exclusion2);
@ -5043,7 +5045,6 @@ static int mark_rename_table_MARK(void *p) {
gcMARK(rn->nomarshal_ht);
gcMARK(rn->unmarshal_info);
gcMARK(rn->shared_pes);
gcMARK(rn->plus_kernel_nominal_source);
gcMARK(rn->set_identity);
gcMARK(rn->marked_names);
gcMARK(rn->free_id_renames);
@ -5058,7 +5059,6 @@ static int mark_rename_table_FIXUP(void *p) {
gcFIXUP(rn->nomarshal_ht);
gcFIXUP(rn->unmarshal_info);
gcFIXUP(rn->shared_pes);
gcFIXUP(rn->plus_kernel_nominal_source);
gcFIXUP(rn->set_identity);
gcFIXUP(rn->marked_names);
gcFIXUP(rn->free_id_renames);
@ -5216,6 +5216,40 @@ static int lex_rib_FIXUP(void *p) {
#define lex_rib_IS_CONST_SIZE 1
static int mark_free_id_info_SIZE(void *p) {
return
gcBYTES_TO_WORDS((sizeof(Scheme_Vector)
+ ((8 - 1) * sizeof(Scheme_Object *))));
}
static int mark_free_id_info_MARK(void *p) {
Scheme_Vector *vec = (Scheme_Vector *)p;
int i;
for (i = 8; i--; )
gcMARK(vec->els[i]);
return
gcBYTES_TO_WORDS((sizeof(Scheme_Vector)
+ ((8 - 1) * sizeof(Scheme_Object *))));
}
static int mark_free_id_info_FIXUP(void *p) {
Scheme_Vector *vec = (Scheme_Vector *)p;
int i;
for (i = 8; i--; )
gcFIXUP(vec->els[i]);
return
gcBYTES_TO_WORDS((sizeof(Scheme_Vector)
+ ((8 - 1) * sizeof(Scheme_Object *))));
}
#define mark_free_id_info_IS_ATOMIC 0
#define mark_free_id_info_IS_CONST_SIZE 0
#endif /* STXOBJ */
/**********************************************************************/

16
src/mzscheme/src/mzmarksrc.c
View File

@ -990,6 +990,7 @@ module_phase_exports_val {
gcMARK(m->provide_src_names);
gcMARK(m->provide_nominal_srcs);
gcMARK(m->provide_src_phases);
gcMARK(m->provide_insps);
gcMARK(m->kernel_exclusion);
gcMARK(m->kernel_exclusion2);
@ -2070,7 +2071,6 @@ mark_rename_table {
gcMARK(rn->nomarshal_ht);
gcMARK(rn->unmarshal_info);
gcMARK(rn->shared_pes);
gcMARK(rn->plus_kernel_nominal_source);
gcMARK(rn->set_identity);
gcMARK(rn->marked_names);
gcMARK(rn->free_id_renames);
@ -2133,6 +2133,20 @@ lex_rib {
gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib));
}
mark_free_id_info {
mark:
Scheme_Vector *vec = (Scheme_Vector *)p;
int i;
for (i = 8; i--; )
gcMARK(vec->els[i]);
size:
gcBYTES_TO_WORDS((sizeof(Scheme_Vector)
+ ((8 - 1) * sizeof(Scheme_Object *))));
}
END stxobj;
/**********************************************************************/

17
src/mzscheme/src/schpriv.h
View File

@ -779,14 +779,14 @@ Scheme_Object* scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *mod
Scheme_Object *locname, Scheme_Object *exname,
Scheme_Object *nominal_src, Scheme_Object *nominal_ex,
int mod_phase, Scheme_Object *src_phase_index,
Scheme_Object *nom_export_phase, int drop_for_marshal);
Scheme_Object *nom_export_phase, Scheme_Object *insp,
int mode);
void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx,
struct Scheme_Module_Phase_Exports *pt,
Scheme_Object *unmarshal_phase_index,
Scheme_Object *src_phase_index,
Scheme_Object *marks,
int save_unmarshal);
void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src);
void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info);
void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to,
@ -809,7 +809,7 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist);
int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase);
int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym);
Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase);
Scheme_Object *scheme_stx_module_name(int recur,
Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *recur,
Scheme_Object **name, Scheme_Object *phase,
Scheme_Object **nominal_modidx,
Scheme_Object **nominal_name,
@ -817,7 +817,8 @@ Scheme_Object *scheme_stx_module_name(int recur,
Scheme_Object **src_phase_index,
Scheme_Object **nominal_src_phase,
Scheme_Object **lex_env,
int *_sealed);
int *_sealed,
Scheme_Object **rename_insp);
Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a);
int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx);
@ -1140,7 +1141,7 @@ typedef struct Scheme_Cont_Mark_Set {
Scheme_Object *native_stack_trace;
} Scheme_Cont_Mark_Set;
#define SCHEME_LOG_MARK_SEGMENT_SIZE 8
#define SCHEME_LOG_MARK_SEGMENT_SIZE 6
#define SCHEME_MARK_SEGMENT_SIZE (1 << SCHEME_LOG_MARK_SEGMENT_SIZE)
#define SCHEME_MARK_SEGMENT_MASK (SCHEME_MARK_SEGMENT_SIZE - 1)
@ -2653,10 +2654,10 @@ typedef struct Scheme_Module_Phase_Exports
Scheme_Object **provide_src_names; /* symbols (original internal names) */
Scheme_Object **provide_nominal_srcs; /* import source if re-exported; NULL or array of lists */
char *provide_src_phases; /* NULL, or src phase for for-syntax import */
Scheme_Object **provide_insps; /* inspectors for re-provided protected/unexported */
int num_provides;
int num_var_provides; /* non-syntax listed first in provides */
int reprovide_kernel; /* if true, extend provides with kernel's */
Scheme_Object *kernel_exclusion; /* we allow up to two exns, but they must be shadowed */
Scheme_Object *kernel_exclusion2;
@ -2730,8 +2731,10 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem
Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx,
Scheme_Object *symbol, Scheme_Object *stx,
Scheme_Object *certs, Scheme_Object *unexp_insp,
Scheme_Object *rename_insp,
int position, int want_pos,
int *_protected, Scheme_Env *from_env);
int *_protected, int *_unexported,
Scheme_Env *from_env, int *_would_complain);
Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name);
Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.1.5.4"
#define MZSCHEME_VERSION "4.1.5.5"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 5
#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)

22
src/mzscheme/src/struct.c
View File

@ -2164,19 +2164,29 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
pos = parse_pos(who, i, argv, argc);
if (argc > 2) {
if (!SCHEME_SYMBOLP(argv[2])) {
scheme_wrong_type(who, "symbol", 2, argc, argv);
return NULL;
if (SCHEME_FALSEP(argv[2])) {
fieldstr = NULL;
fieldstrlen = 0;
} else {
if (!SCHEME_SYMBOLP(argv[2])) {
scheme_wrong_type(who, "symbol or #f", 2, argc, argv);
return NULL;
}
fieldstr = scheme_symbol_val(argv[2]);
fieldstrlen = SCHEME_SYM_LEN(argv[2]);
}
fieldstr = scheme_symbol_val(argv[2]);
fieldstrlen = SCHEME_SYM_LEN(argv[2]);
} else {
sprintf(digitbuf, "field%d", (int)SCHEME_INT_VAL(argv[1]));
fieldstr = digitbuf;
fieldstrlen = strlen(fieldstr);
}
if (getter) {
if (!fieldstr) {
if (getter)
name = "accessor";
else
name = "mutator";
} else if (getter) {
name = (char *)GET_NAME((char *)i->struct_type->name, -1,
fieldstr, fieldstrlen, 0);
} else {

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

@ -71,6 +71,9 @@ static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv);
static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active);
static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj);
static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj);
static Scheme_Object *source_symbol; /* uninterned! */
static Scheme_Object *share_symbol; /* uninterned! */
static Scheme_Object *origin_symbol;
@ -88,6 +91,7 @@ static Scheme_Stx_Srcloc *empty_srcloc;
static Scheme_Object *empty_simplified;
static Scheme_Hash_Table *empty_hash_table;
static THREAD_LOCAL Scheme_Hash_Table *quick_hash_table;
static THREAD_LOCAL Scheme_Object *last_phase_shift;
@ -129,16 +133,16 @@ XFORM_NONGCING static int prefab_p(Scheme_Object *o)
typedef struct Module_Renames {
Scheme_Object so; /* scheme_rename_table_type */
char plus_kernel, kind, needs_unmarshal;
char kind, needs_unmarshal;
char sealed; /* 1 means bound won't change; 2 means unbound won't change, either */
Scheme_Object *phase;
Scheme_Object *plus_kernel_nominal_source;
Scheme_Object *set_identity;
Scheme_Hash_Table *ht; /* localname -> modidx OR
(cons modidx exportname) OR
(cons modidx nominal_modidx) OR
(list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR
(list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname)
(list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) OR
(cons insp localname)
nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase)
import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */
Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */
@ -217,6 +221,14 @@ static Module_Renames *krn;
#define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type))
static int is_rename_inspector_info(Scheme_Object *v)
{
return (SAME_TYPE(SCHEME_TYPE(v), scheme_inspector_type)
|| (SCHEME_PAIRP(v)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(v)), scheme_inspector_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(v)), scheme_inspector_type)));
}
/* Wraps:
A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a
@ -241,11 +253,11 @@ static Module_Renames *krn;
(cons <var-resolved> (cons <id> <phase>)) =>
free-id=? renaming to <id> on match
- A wrap-elem (vector <free-id-renames?> <ht> <sym> ... <sym> ...) is also a lexical rename
var resolved: sym or (cons <sym> <bind-info>),
where <bind-info> is module/lexical binding info:
(cons <sym> #f) => top-level binding
(cons <sym> <sym>) => lexical binding
(vector ...) => module-binding
bool var resolved: sym or (cons <sym> <bind-info>),
where <bind-info> is module/lexical binding info:
(cons <sym> #f) => top-level binding
(cons <sym> <sym>) => lexical binding
(free-eq-info ...) => module-binding
where the variables have already been resolved and filtered (no mark
or lexical-env comparison needed with the remaining wraps)
@ -570,6 +582,8 @@ void scheme_init_stx(Scheme_Env *env)
REGISTER_SO(nominal_ipair_cache);
REGISTER_SO(quick_hash_table);
REGISTER_SO(last_phase_shift);
REGISTER_SO(empty_hash_table);
@ -583,6 +597,9 @@ void scheme_init_stx(Scheme_Env *env)
SCHEME_SET_IMMUTABLE(no_nested_inactive_certs);
REGISTER_SO(unsealed_dependencies);
scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix);
scheme_install_type_reader(scheme_free_id_info_type, read_free_id_info_prefix);
}
/*========================================================================*/
@ -1352,15 +1369,6 @@ static void check_not_sealed(Module_Renames *mrn)
scheme_signal_error("internal error: attempt to change sealed module rename");
}
void scheme_extend_module_rename_with_kernel(Scheme_Object *mrn, Scheme_Object *nominal_mod)
{
/* Don't use on a non-module namespace, where renames may need
to be removed... */
check_not_sealed((Module_Renames *)mrn);
((Module_Renames *)mrn)->plus_kernel = 1;
((Module_Renames *)mrn)->plus_kernel_nominal_source = nominal_mod;
}
static Scheme_Object *phase_to_index(Scheme_Object *phase)
{
return phase;
@ -1375,6 +1383,7 @@ Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn,
int mod_phase, /* phase of source defn */
Scheme_Object *src_phase_index, /* nominal import phase */
Scheme_Object *nom_phase, /* nominal export phase */
Scheme_Object *insp, /* inspector for re-export */
int mode) /* 1 => can be reconstructed from unmarshal info
2 => free-id=? renaming
3 => return info */
@ -1430,6 +1439,9 @@ Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn,
elem = CONS(modname, elem);
}
if (insp)
elem = CONS(insp, elem);
if (mode == 1) {
if (!((Module_Renames *)mrn)->nomarshal_ht) {
Scheme_Hash_Table *ht;
@ -1497,11 +1509,6 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
check_not_sealed((Module_Renames *)dest);
if (((Module_Renames *)src)->plus_kernel) {
((Module_Renames *)dest)->plus_kernel = 1;
((Module_Renames *)dest)->plus_kernel_nominal_source = ((Module_Renames *)src)->plus_kernel_nominal_source;
}
if (do_pes) {
if (!SCHEME_NULLP(((Module_Renames *)src)->shared_pes)) {
Scheme_Object *first = NULL, *last = NULL, *pr, *l;
@ -1559,6 +1566,14 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
if (hts->vals[i]) {
v = hts->vals[i];
if (old_midx) {
Scheme_Object *insp = NULL;
if (SCHEME_PAIRP(v) && is_rename_inspector_info(SCHEME_CAR(v))) {
insp = SCHEME_CAR(v);
v = SCHEME_CDR(v);
} else
insp = NULL;
/* Shift the modidx part */
if (SCHEME_PAIRP(v)) {
if (SCHEME_PAIRP(SCHEME_CDR(v))) {
@ -1597,6 +1612,9 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
/* modidx */
v = scheme_modidx_shift(v, old_midx, new_midx);
}
if (insp)
v = CONS(insp, v);
}
scheme_hash_set(ht, hts->keys[i], v);
if (drop_ht)
@ -1698,12 +1716,6 @@ void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht)
for (i = pt->num_provides; i--; ) {
scheme_hash_set(ht, pt->provides[i], scheme_false);
}
if (pt->reprovide_kernel)
scheme_list_module_rename((Scheme_Object *)krn, ht);
}
if (src->plus_kernel) {
scheme_list_module_rename((Scheme_Object *)krn, ht);
}
}
@ -1930,10 +1942,29 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib)
return scheme_add_rename(o, rib);
}
static Scheme_Hash_Table *make_recur_table()
{
if (quick_hash_table) {
GC_CAN_IGNORE Scheme_Hash_Table *t;
t = quick_hash_table;
quick_hash_table = NULL;
return t;
} else
return scheme_make_hash_table(SCHEME_hash_ptr);
}
static void release_recur_table(Scheme_Hash_Table *free_id_recur)
{
if (!free_id_recur->size && !quick_hash_table) {
quick_hash_table = free_id_recur;
}
}
static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn,
Scheme_Object *id,
Scheme_Object *orig_id,
int *_sealed)
int *_sealed,
Scheme_Hash_Table *free_id_recur)
{
Scheme_Object *result;
Scheme_Object *modname;
@ -1943,17 +1974,24 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn,
Scheme_Object *src_phase_index;
Scheme_Object *nominal_src_phase;
Scheme_Object *lex_env;
Scheme_Object *rename_insp;
if (scheme_hash_get(free_id_recur, id)) {
return id;
}
scheme_hash_set(free_id_recur, id, id);
nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL);
modname = scheme_stx_module_name(1,
modname = scheme_stx_module_name(free_id_recur,
&orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx,
&nominal_name,
&mod_phase,
&src_phase_index,
&nominal_src_phase,
&lex_env,
_sealed);
_sealed,
&rename_insp);
if (SCHEME_SYMBOLP(nom2))
nominal_name = nom2;
@ -1972,6 +2010,7 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn,
SCHEME_INT_VAL(mod_phase), /* phase of source defn */
src_phase_index, /* nominal import phase */
nominal_src_phase, /* nominal export phase */
rename_insp,
3);
if (*_sealed) {
@ -3683,7 +3722,7 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes,
Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL;
Scheme_Module_Phase_Exports *pt;
Scheme_Hash_Table *ht;
int i, phase, best_match_len = -1, skip;
int i, phase, best_match_len = -1, skip = 0;
Scheme_Object *marks_cache = NULL;
for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) {
@ -3744,6 +3783,7 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes,
if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */
get_names[4] = SCHEME_CDR(get_names[4]);
get_names[5] = pt->phase_index;
get_names[6] = (pt->provide_insps ? pt->provide_insps[i] : NULL);
}
if (SCHEME_FALSEP(src)) {
@ -3755,34 +3795,6 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes,
best_match = src;
}
}
} else if (pt->reprovide_kernel) {
Scheme_Object *kpr;
kpr = scheme_hash_get(krn->ht, glob_id);
if (kpr) {
/* Found it, maybe. Check marks. */
int mark_len, skip;
mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth, &skip);
if (mark_len > best_match_len) {
/* Marks match and improve on previously found match. Build suitable rename: */
best_match_len = mark_len;
if (_skipped) *_skipped = skip;
if (get_orig_name)
best_match = glob_id;
else {
if (get_names) {
idx = SCHEME_CAR(SCHEME_CAR(kpr));
get_names[0] = glob_id;
get_names[1] = idx;
get_names[2] = glob_id;
get_names[3] = scheme_make_integer(0);
get_names[4] = pt->phase_index;
get_names[5] = scheme_make_integer(0);
}
best_match = scheme_get_kernel_modidx();
}
}
}
}
}
@ -3939,13 +3951,16 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *a, Scheme_Object *orig_phase,
int w_mod, Scheme_Object **get_names,
Scheme_Object *skip_ribs, int *_binding_marks_skipped,
int *_depends_on_unsealed_rib, int depth, int get_free_id_info)
int *_depends_on_unsealed_rib, int depth,
Scheme_Hash_Table *free_id_recur)
/* Module binding ignored if w_mod is 0.
If module bound, result is module idx, and get_names[0] is set to source name,
get_names[1] is set to the nominal source module, get_names[2] is set to
the nominal source module's export, get_names[3] is set to the phase of
the source definition, and get_names[4] is set to the nominal import phase index,
and get_names[5] is set to the nominal export phase.
and get_names[5] is set to the nominal export phase; get_names[6] is set to
an inspector/pair if one applies for a re-export of a protected or unexported, NULL or
#f otherwise.
If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined;
get_names[1] is set if a free-id=? rename provides a different name for the bindig.
If neither, result is #f and get_names[0] is either unchanged or NULL; get_names[1]
@ -3953,7 +3968,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
{
WRAP_POS wraps;
Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs;
Scheme_Object *mresult = scheme_false;
Scheme_Object *mresult = scheme_false, *mresult_insp;
Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL;
Scheme_Object *rename_stack[QUICK_STACK_SIZE];
int stack_pos = 0, no_lexical = 0;
@ -4024,7 +4039,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (mresult_depends_unsealed)
depends_on_unsealed_rib = 1;
} else {
if (get_free_id_info && !SCHEME_VOIDP(result_free_rename)) {
if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) {
Scheme_Object *orig;
int rib_dep = 0;
orig = result_free_rename;
@ -4035,10 +4050,14 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]);
if (get_names)
get_names[1] = NULL;
result = resolve_env(NULL, SCHEME_CAR(result_free_rename), phase,
w_mod, get_names,
NULL, _binding_marks_skipped,
&rib_dep, depth + 1, 1);
result = SCHEME_CAR(result_free_rename);
if (!scheme_hash_get(free_id_recur, result)) {
scheme_hash_set(free_id_recur, result, scheme_true);
result = resolve_env(NULL, result, phase,
w_mod, get_names,
NULL, _binding_marks_skipped,
&rib_dep, depth + 1, free_id_recur);
}
if (get_names && !get_names[1])
if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0]))
get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename));
@ -4048,7 +4067,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
result = SCHEME_CDR(result_free_rename);
if (get_names)
get_names[0] = scheme_undefined;
} else if (SCHEME_VECTORP(result_free_rename)) {
} else if (SAME_OBJ(SCHEME_TYPE(result_free_rename), scheme_free_id_info_type)) {
result = SCHEME_VEC_ELS(result_free_rename)[0];
if (get_names) {
get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1];
@ -4057,6 +4076,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4];
get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5];
get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6];
get_names[6] = SCHEME_VEC_ELS(result_free_rename)[7];
}
} else {
if (get_names)
@ -4123,7 +4143,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth));
if (!bdg) {
EXPLAIN(fprintf(stderr, "%d get bdg\n", depth));
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, 0);
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL);
if (SCHEME_FALSEP(bdg)) {
if (!floating_checked) {
floating = check_floating_id(a);
@ -4153,14 +4173,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0)));
if (get_free_id_info && mrn->free_id_renames) {
if (free_id_recur && mrn->free_id_renames) {
rename = scheme_hash_get(mrn->free_id_renames, glob_id);
if (rename && SCHEME_STXP(rename)) {
int sealed;
rename = extract_module_free_id_binding((Scheme_Object *)mrn,
glob_id,
rename,
&sealed);
&sealed,
free_id_recur);
if (!sealed)
mresult_depends_unsealed = 1;
}
@ -4170,10 +4191,6 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
rename = scheme_hash_get(mrn->ht, glob_id);
if (!rename && mrn->nomarshal_ht)
rename = scheme_hash_get(mrn->nomarshal_ht, glob_id);
if (!rename && mrn->plus_kernel) {
rename = scheme_hash_get(krn->ht, glob_id);
nominal = mrn->plus_kernel_nominal_source;
}
get_names_done = 0;
if (!rename) {
EXPLAIN(fprintf(stderr, "%d in pes\n", depth));
@ -4199,6 +4216,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
/* match; set mresult, which is used in the case of no lexical capture: */
mresult_skipped = skipped;
mresult_insp = NULL;
if (SCHEME_BOXP(rename)) {
/* This should only happen for mappings from free_id_renames */
mresult = SCHEME_BOX_VAL(rename);
@ -4211,9 +4230,14 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
mresult = SCHEME_CDR(mresult);
} else {
if (SCHEME_PAIRP(rename))
if (SCHEME_PAIRP(rename)) {
mresult = SCHEME_CAR(rename);
else
if (is_rename_inspector_info(mresult)) {
mresult_insp = mresult;
rename = SCHEME_CDR(rename);
mresult = SCHEME_CAR(rename);
}
} else
mresult = rename;
if (modidx_shift_from)
@ -4281,6 +4305,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (!get_names[5]) {
get_names[5] = get_names[3];
}
get_names[6] = mresult_insp;
}
if (modidx_shift_from && !no_shift) {
@ -4416,7 +4441,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (SCHEME_VOIDP(other_env)) {
int rib_dep = 0;
SCHEME_USE_FUEL(1);
other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, 0);
other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL);
{
Scheme_Object *e;
e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs,
@ -4449,7 +4474,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
top element of the stack and combine the two
mappings, but the intermediate name may be needed
(for other_env values that don't come from this stack). */
if (get_free_id_info && !SCHEME_VOIDP(free_id_rename)) {
if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) {
/* Need to remember phase ad shifts for free-id=? rename: */
Scheme_Object *vec;
vec = scheme_make_vector(4, NULL);
@ -4535,7 +4560,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
}
static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, int use_free_id_renames)
static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase,
Scheme_Hash_Table *free_id_recur)
/* Gets a module source name under the assumption that the identifier
is not lexically renamed. This is used as a quick pre-test for
free-identifier=?. We do have to look at lexical renames to check for
@ -4545,11 +4571,11 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
WRAP_POS wraps;
Scheme_Object *result, *result_from;
int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0;
int no_lexical = !use_free_id_renames;
int no_lexical = !free_id_recur;
Scheme_Object *phase = orig_phase;
Scheme_Object *bdg = NULL, *floating = NULL;
if (!use_free_id_renames
if (!free_id_recur
&& SAME_OBJ(phase, scheme_make_integer(0))
&& ((Scheme_Stx *)a)->u.modinfo_cache)
return ((Scheme_Stx *)a)->u.modinfo_cache;
@ -4568,7 +4594,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
if (!result)
result = SCHEME_STX_VAL(a);
if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !use_free_id_renames)
if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur)
((Scheme_Stx *)a)->u.modinfo_cache = result;
return result;
@ -4609,13 +4635,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
if (mrn->needs_unmarshal) {
/* Use resolve_env to trigger unmarshal, so that we
don't have to implement top/from shifts here: */
resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, 0);
resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, NULL);
}
if (mrn->marked_names) {
/* Resolve based on rest of wraps: */
if (!bdg)
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, 0);
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
if (SCHEME_FALSEP(bdg)) {
if (!floating_checked) {
floating = check_floating_id(a);
@ -4634,14 +4660,15 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
} else
glob_id = SCHEME_STX_VAL(a);
if (use_free_id_renames && mrn->free_id_renames) {
if (free_id_recur && mrn->free_id_renames) {
rename = scheme_hash_get(mrn->free_id_renames, glob_id);
if (rename && SCHEME_STXP(rename)) {
int sealed;
rename = extract_module_free_id_binding((Scheme_Object *)mrn,
glob_id,
rename,
&sealed);
&sealed,
free_id_recur);
if (!sealed)
sealed = 0;
}
@ -4651,8 +4678,6 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
rename = scheme_hash_get(mrn->ht, glob_id);
if (!rename && mrn->nomarshal_ht)
rename = scheme_hash_get(mrn->nomarshal_ht, glob_id);
if (!rename && mrn->plus_kernel)
rename = scheme_hash_get(krn->ht, glob_id);
if (!rename)
result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL);
@ -4745,7 +4770,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
if (SCHEME_PAIRP(renames)) {
/* Has a relevant-looking free-id mapping.
Give up on the "fast" traversal. */
Scheme_Object *modname, *names[6];
Scheme_Object *modname, *names[7];
int rib_dep;
names[0] = NULL;
@ -4753,8 +4778,9 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
names[3] = scheme_make_integer(0);
names[4] = NULL;
names[5] = NULL;
names[6] = NULL;
modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, 1);
modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur);
if (rib_dep)
sealed = 0;
@ -4784,18 +4810,27 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym)
{
Scheme_Object *bsym;
Scheme_Hash_Table *free_id_recur;
if (!a || !b)
return (a == b);
if (SCHEME_STXP(b))
bsym = get_module_src_name(b, phase, !asym);
else
if (SCHEME_STXP(b)) {
if (!asym)
free_id_recur = make_recur_table();
else
free_id_recur = NULL;
bsym = get_module_src_name(b, phase, free_id_recur);
if (!asym)
release_recur_table(free_id_recur);
} else
bsym = b;
if (!asym) {
if (SCHEME_STXP(a))
asym = get_module_src_name(a, phase, 1);
else
if (SCHEME_STXP(a)) {
free_id_recur = make_recur_table();
asym = get_module_src_name(a, phase, free_id_recur);
release_recur_table(free_id_recur);
} else
asym = a;
}
@ -4806,8 +4841,13 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
if ((a == asym) || (b == bsym))
return 1;
a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, 1);
b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, 1);
free_id_recur = make_recur_table();
a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
release_recur_table(free_id_recur);
free_id_recur = make_recur_table();
b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
release_recur_table(free_id_recur);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
a = scheme_module_resolve(a, 0);
@ -4826,12 +4866,12 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase)
Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase)
{
if (SCHEME_STXP(a))
return get_module_src_name(a, phase, 0);
return get_module_src_name(a, phase, NULL);
else
return a;
}
Scheme_Object *scheme_stx_module_name(int recur,
Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur,
Scheme_Object **a, Scheme_Object *phase,
Scheme_Object **nominal_modidx, /* how it was imported */
Scheme_Object **nominal_name, /* imported as name */
@ -4839,7 +4879,8 @@ Scheme_Object *scheme_stx_module_name(int recur,
Scheme_Object **src_phase_index, /* phase level of import from nominal modidx */
Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */
Scheme_Object **lex_env,
int *_sealed)
int *_sealed,
Scheme_Object **insp)
/* If module bound, result is module idx, and a is set to source name.
If lexically bound, result is scheme_undefined, a is unchanged,
and nominal_name is NULL or a free_id=? renamed id.
@ -4847,7 +4888,7 @@ Scheme_Object *scheme_stx_module_name(int recur,
and nominal_name is NULL or a free_id=? renamed id. */
{
if (SCHEME_STXP(*a)) {
Scheme_Object *modname, *names[6];
Scheme_Object *modname, *names[7];
int rib_dep;
names[0] = NULL;
@ -4855,8 +4896,9 @@ Scheme_Object *scheme_stx_module_name(int recur,
names[3] = scheme_make_integer(0);
names[4] = NULL;
names[5] = NULL;
names[6] = NULL;
modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, recur);
modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, free_id_recur);
if (_sealed) *_sealed = !rib_dep;
@ -4879,6 +4921,8 @@ Scheme_Object *scheme_stx_module_name(int recur,
*src_phase_index = names[4];
if (nominal_src_phase)
*nominal_src_phase = names[5];
if (insp)
*insp = names[6];
return modname;
}
} else {
@ -4902,8 +4946,8 @@ int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs)
skip_ribs = SCHEME_CDR(skip_ribs);
}
m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, 0);
m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, 0);
m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, NULL);
m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, NULL);
return !SAME_OBJ(m1, m2);
}
@ -4914,7 +4958,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a)
if (SCHEME_STXP(a)) {
Scheme_Object *r;
r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, 0);
r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, NULL);
if (SCHEME_FALSEP(r))
r = check_floating_id(a);
@ -4946,13 +4990,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
if (!SAME_OBJ(asym, bsym))
return 0;
ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, 0);
ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
/* No need to module_resolve ae, because we ignored module renamings. */
if (uid)
be = uid;
else {
be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, 0);
be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
/* No need to module_resolve be, because we ignored module renamings. */
}
@ -4982,7 +5026,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase
Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a)
{
scheme_explain_resolves++;
a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, 1);
a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, NULL);
--scheme_explain_resolves;
return a;
}
@ -5378,17 +5422,20 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id)
Scheme_Object *src_phase_index;
Scheme_Object *nominal_src_phase;
Scheme_Object *lex_env = NULL;
Scheme_Object *vec, *phase;
Scheme_Object *vec, *phase, *insp;
Scheme_Hash_Table *free_id_recur;
phase = SCHEME_CDR(id);
id = SCHEME_CAR(id);
nom2 = scheme_stx_property(id, nominal_id_symbol, NULL);
bind = scheme_stx_module_name(1,
free_id_recur = make_recur_table();
bind = scheme_stx_module_name(free_id_recur,
&id, phase, &nominal_modidx, &nominal_name,
&mod_phase, &src_phase_index, &nominal_src_phase,
&lex_env, NULL);
&lex_env, NULL, &insp);
release_recur_table(free_id_recur);
if (SCHEME_SYMBOLP(nom2))
nominal_name = nom2;
@ -5400,7 +5447,8 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id)
else if (SAME_OBJ(bind, scheme_undefined))
return CONS(nominal_name, lex_env);
else {
vec = scheme_make_vector(7, NULL);
vec = scheme_make_vector(8, NULL);
vec->type = scheme_free_id_info_type;
SCHEME_VEC_ELS(vec)[0] = bind;
SCHEME_VEC_ELS(vec)[1] = id;
SCHEME_VEC_ELS(vec)[2] = nominal_modidx;
@ -5408,6 +5456,7 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id)
SCHEME_VEC_ELS(vec)[4] = mod_phase;
SCHEME_VEC_ELS(vec)[5] = src_phase_index;
SCHEME_VEC_ELS(vec)[6] = nominal_src_phase;
SCHEME_VEC_ELS(vec)[7] = (insp ? insp : scheme_false);
return vec;
}
}
@ -5534,7 +5583,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
other_env = filter_cached_env(other_env, prec_ribs);
if (SCHEME_VOIDP(other_env)) {
int rib_dep;
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0);
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL);
if (rib_dep) {
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
return NULL;
@ -5707,7 +5756,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
other_env = filter_cached_env(other_env, prec_ribs);
if (SCHEME_VOIDP(other_env)) {
int rib_dep;
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0);
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL);
if (rib_dep) {
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
return NULL;
@ -6119,15 +6168,16 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
if (mrn->free_id_renames->vals[i]) {
if (SCHEME_STXP(mrn->free_id_renames->vals[i])) {
int sealed;
Scheme_Hash_Table *free_id_recur;
free_id_recur = make_recur_table();
b = extract_module_free_id_binding((Scheme_Object *)mrn,
mrn->free_id_renames->keys[i],
mrn->free_id_renames->vals[i],
&sealed);
&sealed,
free_id_recur);
release_recur_table(free_id_recur);
if (!sealed) {
extract_module_free_id_binding((Scheme_Object *)mrn,
mrn->free_id_renames->keys[i],
mrn->free_id_renames->vals[i],
&sealed);
scheme_signal_error("write: unsealed local-definition or module context"
" found in syntax object");
}
@ -6158,7 +6208,15 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
for (i = ht->size, j = 0; i--; ) {
if (ht->vals[i]) {
SCHEME_VEC_ELS(l)[j++] = ht->keys[i];
SCHEME_VEC_ELS(l)[j++] = ht->vals[i];
fil = ht->vals[i];
if (SCHEME_PAIRP(fil) && is_rename_inspector_info(SCHEME_CAR(fil))) {
/* use 1 or 2 to indicate inspector info */
if (SCHEME_PAIRP(SCHEME_CAR(fil)))
fil = CONS(scheme_make_integer(2), SCHEME_CDR(fil));
else
fil = CONS(scheme_make_integer(1), SCHEME_CDR(fil));
}
SCHEME_VEC_ELS(l)[j++] = fil;
}
}
@ -6205,10 +6263,6 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
l = CONS(mrn->set_identity, l);
l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l);
l = CONS(mrn->phase, l);
if (mrn->plus_kernel) {
l = CONS(scheme_true,l);
/* FIXME: plus-kernel nominal omitted */
}
local_key = scheme_marshal_lookup(mt, a);
if (local_key)
@ -6731,7 +6785,7 @@ static int ok_phase_index(Scheme_Object *o) {
static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok)
{
int count, i;
Scheme_Object *key, *p;
Scheme_Object *key, *p0, *p;
if (!SCHEME_VECTORP(a)) return_NULL;
count = SCHEME_VEC_SIZE(a);
@ -6739,10 +6793,22 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl
for (i = 0; i < count; i+= 2) {
key = SCHEME_VEC_ELS(a)[i];
p = SCHEME_VEC_ELS(a)[i+1];
p0 = SCHEME_VEC_ELS(a)[i+1];
if (!SCHEME_SYMBOLP(key)) return_NULL;
p = p0;
if (SCHEME_PAIRP(p) && SCHEME_INTP(SCHEME_CAR(p))) {
/* reconstruct inspector info */
Scheme_Object *insp;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
if (!SAME_OBJ(scheme_make_integer(1), SCHEME_CAR(p))) {
insp = CONS(scheme_make_inspector(insp), insp);
}
p = SCHEME_CDR(p0);
p0 = CONS(insp, p);
}
if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) {
/* Ok */
} else if (SCHEME_PAIRP(p)) {
@ -6816,7 +6882,7 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl
} else
return_NULL;
scheme_hash_set(ht, key, p);
scheme_hash_set(ht, key, p0);
}
return scheme_true;
@ -6910,9 +6976,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
v = SCHEME_CDR(v);
if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v))
return_NULL;
} else if (SCHEME_VECTORP(v)) {
if (SCHEME_VEC_SIZE(v) != 7)
return_NULL;
} else if (SAME_TYPE(SCHEME_TYPE(v), scheme_free_id_info_type)) {
if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0])
|| !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1])
|| !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2])
@ -6947,7 +7011,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
Scheme_Object *mns;
Module_Renames *mrn;
Scheme_Object *p, *key;
int plus_kernel, kind;
int kind;
Scheme_Object *phase, *set_identity;
if (!SCHEME_PAIRP(a)) return_NULL;
@ -6955,10 +7019,8 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
/* Convert list to rename table: */
if (SAME_OBJ(SCHEME_CAR(a), scheme_true)) {
plus_kernel = 1;
a = SCHEME_CDR(a);
} else
plus_kernel = 0;
scheme_signal_error("leftover plus-kernel");
}
if (!SCHEME_PAIRP(a)) return_NULL;
phase = SCHEME_CAR(a);
@ -6978,7 +7040,6 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
a = SCHEME_CDR(a);
mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL);
mrn->plus_kernel = plus_kernel;
mrn->set_identity = set_identity;
if (!SCHEME_PAIRP(a)) return_NULL;
@ -7800,7 +7861,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache)
if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) {
fprintf(stderr,
"simplifying... %s\n",
scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0),
scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL),
NULL));
explain_simp = 1;
}
@ -7818,7 +7879,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache)
if (explain_simp) {
explain_simp = 0;
fprintf(stderr, "simplified: %s\n",
scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0),
scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL),
NULL));
}
#endif
@ -8310,7 +8371,8 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv)
int skipped = -1;
Scheme_Object *mod;
mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, 1);
mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0,
scheme_make_hash_table(SCHEME_hash_ptr));
if ((skipped == -1) && SCHEME_FALSEP(mod)) {
/* For top-level bindings, need to check the current environment's table,
@ -8436,7 +8498,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
phase = scheme_bin_plus(dphase, phase);
}
m = scheme_stx_module_name(1,
m = scheme_stx_module_name(scheme_make_hash_table(SCHEME_hash_ptr),
&a,
phase,
&nom_mod, &nom_a,
@ -8444,6 +8506,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
&src_phase_index,
&nominal_src_phase,
NULL,
NULL,
NULL);
if (!m)
@ -8717,6 +8780,47 @@ Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht)
/**********************************************************************/
static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj)
{
Scheme_Object *vec;
int i;
vec = scheme_make_vector(8, NULL);
for (i = 0; i < 8; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i];
}
if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7]))
SCHEME_VEC_ELS(vec)[7] = scheme_true;
return vec;
}
static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj)
{
Scheme_Object *vec, *insp;
int i;
if (!SCHEME_VECTORP(obj)
|| (SCHEME_VEC_SIZE(obj) != 8))
return NULL;
vec = scheme_make_vector(8, NULL);
for (i = 0; i < 8; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i];
}
if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) {
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
SCHEME_VEC_ELS(vec)[7] = insp;
}
vec->type = scheme_free_id_info_type;
return vec;
}
/**********************************************************************/
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
@ -8732,6 +8836,7 @@ static void register_traversers(void)
GC_REG_TRAV(scheme_wrap_chunk_type, mark_wrapchunk);
GC_REG_TRAV(scheme_certifications_type, mark_cert);
GC_REG_TRAV(scheme_lexical_rib_type, lex_rib);
GC_REG_TRAV(scheme_free_id_info_type, mark_free_id_info);
}
END_XFORM_SKIP;

145
src/mzscheme/src/stypes.h
View File

@ -167,84 +167,85 @@ enum {
scheme_module_phase_exports_type, /* 149 */
scheme_logger_type, /* 150 */
scheme_log_reader_type, /* 151 */
scheme_free_id_info_type, /* 152 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 152 */
_scheme_last_normal_type_, /* 153 */
scheme_rt_weak_array, /* 153 */
scheme_rt_weak_array, /* 154 */
scheme_rt_comp_env, /* 154 */
scheme_rt_constant_binding, /* 155 */
scheme_rt_resolve_info, /* 156 */
scheme_rt_optimize_info, /* 157 */
scheme_rt_compile_info, /* 158 */
scheme_rt_cont_mark, /* 159 */
scheme_rt_saved_stack, /* 160 */
scheme_rt_reply_item, /* 161 */
scheme_rt_closure_info, /* 162 */
scheme_rt_overflow, /* 163 */
scheme_rt_overflow_jmp, /* 164 */
scheme_rt_meta_cont, /* 165 */
scheme_rt_dyn_wind_cell, /* 166 */
scheme_rt_dyn_wind_info, /* 167 */
scheme_rt_dyn_wind, /* 168 */
scheme_rt_dup_check, /* 169 */
scheme_rt_thread_memory, /* 170 */
scheme_rt_input_file, /* 171 */
scheme_rt_input_fd, /* 172 */
scheme_rt_oskit_console_input, /* 173 */
scheme_rt_tested_input_file, /* 174 */
scheme_rt_tested_output_file, /* 175 */
scheme_rt_indexed_string, /* 176 */
scheme_rt_output_file, /* 177 */
scheme_rt_load_handler_data, /* 178 */
scheme_rt_pipe, /* 179 */
scheme_rt_beos_process, /* 180 */
scheme_rt_system_child, /* 181 */
scheme_rt_tcp, /* 182 */
scheme_rt_write_data, /* 183 */
scheme_rt_tcp_select_info, /* 184 */
scheme_rt_namespace_option, /* 185 */
scheme_rt_param_data, /* 186 */
scheme_rt_will, /* 187 */
scheme_rt_struct_proc_info, /* 188 */
scheme_rt_linker_name, /* 189 */
scheme_rt_param_map, /* 190 */
scheme_rt_finalization, /* 191 */
scheme_rt_finalizations, /* 192 */
scheme_rt_cpp_object, /* 193 */
scheme_rt_cpp_array_object, /* 194 */
scheme_rt_stack_object, /* 195 */
scheme_rt_preallocated_object, /* 196 */
scheme_thread_hop_type, /* 197 */
scheme_rt_srcloc, /* 198 */
scheme_rt_evt, /* 199 */
scheme_rt_syncing, /* 200 */
scheme_rt_comp_prefix, /* 201 */
scheme_rt_user_input, /* 202 */
scheme_rt_user_output, /* 203 */
scheme_rt_compact_port, /* 204 */
scheme_rt_read_special_dw, /* 205 */
scheme_rt_regwork, /* 206 */
scheme_rt_buf_holder, /* 207 */
scheme_rt_parameterization, /* 208 */
scheme_rt_print_params, /* 209 */
scheme_rt_read_params, /* 210 */
scheme_rt_native_code, /* 211 */
scheme_rt_native_code_plus_case, /* 212 */
scheme_rt_jitter_data, /* 213 */
scheme_rt_module_exports, /* 214 */
scheme_rt_delay_load_info, /* 215 */
scheme_rt_marshal_info, /* 216 */
scheme_rt_unmarshal_info, /* 217 */
scheme_rt_runstack, /* 218 */
scheme_rt_sfs_info, /* 219 */
scheme_rt_validate_clearing, /* 220 */
scheme_rt_rb_node, /* 221 */
scheme_rt_comp_env, /* 155 */
scheme_rt_constant_binding, /* 156 */
scheme_rt_resolve_info, /* 157 */
scheme_rt_optimize_info, /* 158 */
scheme_rt_compile_info, /* 159 */
scheme_rt_cont_mark, /* 160 */
scheme_rt_saved_stack, /* 161 */
scheme_rt_reply_item, /* 162 */
scheme_rt_closure_info, /* 163 */
scheme_rt_overflow, /* 164 */
scheme_rt_overflow_jmp, /* 165 */
scheme_rt_meta_cont, /* 166 */
scheme_rt_dyn_wind_cell, /* 167 */
scheme_rt_dyn_wind_info, /* 168 */
scheme_rt_dyn_wind, /* 169 */
scheme_rt_dup_check, /* 170 */
scheme_rt_thread_memory, /* 171 */
scheme_rt_input_file, /* 172 */
scheme_rt_input_fd, /* 173 */
scheme_rt_oskit_console_input, /* 174 */
scheme_rt_tested_input_file, /* 175 */
scheme_rt_tested_output_file, /* 176 */
scheme_rt_indexed_string, /* 177 */
scheme_rt_output_file, /* 178 */
scheme_rt_load_handler_data, /* 179 */
scheme_rt_pipe, /* 180 */
scheme_rt_beos_process, /* 181 */
scheme_rt_system_child, /* 182 */
scheme_rt_tcp, /* 183 */
scheme_rt_write_data, /* 184 */
scheme_rt_tcp_select_info, /* 185 */
scheme_rt_namespace_option, /* 186 */
scheme_rt_param_data, /* 187 */
scheme_rt_will, /* 188 */
scheme_rt_struct_proc_info, /* 189 */
scheme_rt_linker_name, /* 190 */
scheme_rt_param_map, /* 191 */
scheme_rt_finalization, /* 192 */
scheme_rt_finalizations, /* 193 */
scheme_rt_cpp_object, /* 194 */
scheme_rt_cpp_array_object, /* 195 */
scheme_rt_stack_object, /* 196 */
scheme_rt_preallocated_object, /* 197 */
scheme_thread_hop_type, /* 198 */
scheme_rt_srcloc, /* 199 */
scheme_rt_evt, /* 200 */
scheme_rt_syncing, /* 201 */
scheme_rt_comp_prefix, /* 202 */
scheme_rt_user_input, /* 203 */
scheme_rt_user_output, /* 204 */
scheme_rt_compact_port, /* 205 */
scheme_rt_read_special_dw, /* 206 */
scheme_rt_regwork, /* 207 */
scheme_rt_buf_holder, /* 208 */
scheme_rt_parameterization, /* 209 */
scheme_rt_print_params, /* 210 */
scheme_rt_read_params, /* 211 */
scheme_rt_native_code, /* 212 */
scheme_rt_native_code_plus_case, /* 213 */
scheme_rt_jitter_data, /* 214 */
scheme_rt_module_exports, /* 215 */
scheme_rt_delay_load_info, /* 216 */
scheme_rt_marshal_info, /* 217 */
scheme_rt_unmarshal_info, /* 218 */
scheme_rt_runstack, /* 219 */
scheme_rt_sfs_info, /* 220 */
scheme_rt_validate_clearing, /* 221 */
scheme_rt_rb_node, /* 222 */
#endif
scheme_place_type, /* 222 */
scheme_engine_type, /* 223 */
scheme_place_type, /* 223 */
scheme_engine_type, /* 224 */
_scheme_last_type_
};