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

Sync sync sync, programmer,

Browse Source 
sync your branch to mine
sync sync sync, programmer,
sync it all the time

svn: r12567
This commit is contained in:
Stevie Strickland 2008-11-21 15:56:47 +00:00
commit 998fe27185
42 changed files with 878 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1952,7 +1952,6 @@
(set! red? r?)
(refresh)))
(define/override (on-paint)
(super on-paint)
(when red?
(let ([dc (get-dc)])
(let-values ([(cw ch) (get-client-size)])
@ -1962,7 +1961,8 @@
(send dc set-brush "pink" 'solid)
(send dc draw-rectangle 0 0 cw ch)
(send dc set-pen pen)
(send dc set-brush brush))))))
(send dc set-brush brush)))))
(super on-paint))
(super-new)))
(define-local-member-name

4
collects/gui-debugger/debug-tool.ss
View File

@ -1278,7 +1278,9 @@
(new switchable-button%
(label (string-constant debug-tool-button-name))
(bitmap debug-bitmap)
(parent (make-object vertical-pane% (get-button-panel)))
(parent (new vertical-pane%
[parent (get-button-panel)]
[alignment '(center center)]))
(callback (λ (button) (debug-callback)))))
(inherit register-toolbar-button)
(register-toolbar-button debug-button)

5
collects/macro-debugger/tool.ss
View File

@ -99,7 +99,10 @@
get-definitions-text)
(define macro-debug-panel
(new vertical-pane% (parent (get-button-panel))))
(new horizontal-pane%
(parent (get-button-panel))
(stretchable-height #f)
(stretchable-width #f)))
(define macro-debug-button
(new switchable-button%
(label "Macro Stepper")

2
collects/profj/tool.ss
View File

@ -506,7 +506,7 @@
;default-settings: -> profj-settings
(define/public (default-settings)
(if (memq level `(beginner intermediate intermediate+access advanced))
(make-profj-settings 'field #f #t #f #t #t null)
(make-profj-settings 'field #f #t #f #t #f null)
(make-profj-settings 'type #f #t #t #f #f null)))
;default-settings? any -> bool
(define/public (default-settings? s) (equal? s (default-settings)))

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "20nov2008")
#lang scheme/base (provide stamp) (define stamp "21nov2008")

6
collects/scribblings/tools/frame.scrbl
View File

@ -60,7 +60,7 @@ if the
}
@defmethod[#:mode override
(file-menu:between-open-and-revert [file-menu (is-a?/c @scheme[menu%])])
(file-menu:between-open-and-revert [file-menu (is-a?/c menu%)])
void?]{
Adds an ``Install .plt File...'' menu item, which
@ -72,7 +72,7 @@ method.
}
@defmethod[#:mode override
(file-menu:between-print-and-close [file-menu (is-a?/c @scheme[menu%])])
(file-menu:between-print-and-close [file-menu (is-a?/c menu%)])
void?]{
Calls the super method. Then, creates a menu item for
@ -187,7 +187,7 @@ This interface is the result of the @scheme[drscheme:frame:basics-mixin]
@defmethod[(add-show-menu-items [show-menu (is-a?/c @scheme[menu%])])
@defmethod[(add-show-menu-items [show-menu (is-a?/c menu%)])
void?]{
@methspec{

2
collects/scribblings/tools/language.scrbl
View File

@ -415,7 +415,7 @@ for this language.
}
@defmethod[(get-transformer-module)
(or/c quoted-module-path @scheme[#f])]{
(or/c quoted-module-path #f)]{
This method specifies the module that defines the
transformation language. It is used to initialize
the transformer portion of the user's namespace.

6
collects/scribblings/tools/rep.scrbl
View File

@ -15,7 +15,7 @@ class affect the implementation that uses it.
@defconstructor/make[([context (implements @scheme[drscheme:rep:context<%>])])]{
@defconstructor/make[([context (implements drscheme:rep:context<%>)])]{
}
@defmethod[#:mode override
@ -155,7 +155,7 @@ for more information about parameters.
}
@defmethod[(highlight-errors [locs (listof (list (instance (implements @scheme[text:basic<%>])) small-integer small-integer))])
@defmethod[(highlight-errors [locs (listof (list (instance (implements text:basic<%>)) small-integer small-integer))])
void?]{
Call this method to highlight errors associated with this repl.
See also
@ -382,7 +382,7 @@ See also
}
@defmethod[(ensure-rep-shown [rep (is-a?/c @scheme[drscheme:rep:text<%>])])
@defmethod[(ensure-rep-shown [rep (is-a?/c drscheme:rep:text<%>)])
void?]{
This method is called to force the rep window to be visible when, for

22
collects/scribblings/tools/unit.scrbl
View File

@ -43,7 +43,7 @@ Enables the Run button, and the Run menu item and unlocks
(values (or/c thread? false/c) (or/c custodian? false/c))]{}
@defmethod[(get-defs)
(is-a?/c @scheme[drscheme:unit:definitions-text<%>])]{
(is-a?/c drscheme:unit:definitions-text<%>)]{
This text is initially the top half of the drscheme window and
contains the users program.
@ -73,13 +73,13 @@ is already running (in another thread).
}
@defmethod[(get-frame)
(is-a?/c @scheme[drscheme:unit:frame%])]{
(is-a?/c drscheme:unit:frame%)]{
Returns the frame that this tab is inside.
}
@defmethod[(get-ints)
(is-a?/c @scheme[drscheme:rep:text%])]{
(is-a?/c drscheme:rep:text%)]{
This text is initially the bottom half of the drscheme window and
contains the users interactions with the REPL.
@ -216,7 +216,7 @@ Passes all arguments to @scheme[super-init].
}
@defmethod[#:mode override
(add-show-menu-items [show-menu (is-a?/c @scheme[menu%])])
(add-show-menu-items [show-menu (is-a?/c menu%)])
void?]{
Adds the ``Show Definitions'', ``Show Interactions'' and
@ -570,7 +570,7 @@ Shows the interactions window
}
@defmethod[(get-current-tab)
(is-a?/c @scheme[drscheme:unit:tab<%>])]{
(is-a?/c drscheme:unit:tab<%>)]{
Returns the currently active tab.
}
@ -607,7 +607,7 @@ Returns the Insert menu.
}}
@defmethod[(get-interactions-canvas)
(instanceof (derivedfrom @scheme[drscheme:unit:interactions-canvas%]))]{
(instanceof (derivedfrom drscheme:unit:interactions-canvas%))]{
This canvas is the canvas containing the
@method[drscheme:unit:frame<%> get-interactions-text]. It is initially the bottom half of the drscheme window.
@ -621,7 +621,7 @@ it will use the extended class to create the canvas.
}
@defmethod[(get-interactions-text)
(instanceof (derivedfrom @scheme[drscheme:rep:text%]))]{
(instanceof (derivedfrom drscheme:rep:text%))]{
Calls result of
@method[drscheme:unit:frame<%> get-current-tab]'s
@ -631,7 +631,7 @@ Calls result of
}
@defmethod[(get-tabs)
(listof @scheme[drscheme:unit:tab<%>])]{
(listof drscheme:unit:tab<%>)]{
Returns the list of tabs in this frame.
}
@ -656,7 +656,7 @@ The @scheme[from-tab] argument is the previously selected tab, and the
}}
@defmethod[(register-capability-menu-item [key symbol]
[menu (is-a? @scheme[menu%])])
[menu (is-a? menu%)])
void?]{
Registers the menu item that was most recently added as
being controlled by the capability @scheme[key]. This means
@ -773,7 +773,7 @@ the editor should be used.)
}
@defmethod[(get-tab)
(instanceof @scheme[drscheme:unit:tab%])]{
(instanceof drscheme:unit:tab%)]{
Returns the editor's enclosing tab.
}
@ -807,7 +807,7 @@ an interaction (unless the Runs first).
}}
@defmethod[(set-next-settings [language-settings language-settings]
[update-prefs? any/c @scheme[#t]])
[update-prefs? any/c #t])
void?]{
Changes the language settings for this window. If

22
collects/slideshow/pict.ss
View File

@ -44,9 +44,9 @@
#:line-width [lw #f]
#:color [col #f]
#:under? [under? #f])
(finish-pin (t:pin-line (ghost p)
src find-src
dest find-dest)
(finish-pin (launder (t:pin-line (ghost p)
src find-src
dest find-dest))
p lw col under?))
(define (pin-arrow-line sz p src find-src dest find-dest
@ -54,10 +54,10 @@
#:color [col #f]
#:under? [under? #f]
#:solid? [solid? #t])
(finish-pin (t:pin-arrow-line sz (ghost p)
src find-src
dest find-dest
#f #f #f solid?)
(finish-pin (launder (t:pin-arrow-line sz (ghost p)
src find-src
dest find-dest
#f #f #f solid?))
p lw col under?))
(define (pin-arrows-line sz p src find-src dest find-dest
@ -65,10 +65,10 @@
#:color [col #f]
#:under? [under? #f]
#:solid? [solid? #t])
(finish-pin (t:pin-arrows-line sz (ghost p)
src find-src
dest find-dest
#f #f #f solid?)
(finish-pin (launder (t:pin-arrows-line sz (ghost p)
src find-src
dest find-dest
#f #f #f solid?))
p lw col under?))
(define (finish-pin l p lw col under?)

53
collects/tests/mzscheme/expand.ss
View File

@ -55,8 +55,8 @@
;; really idempotent, on the structure. Assume that
;; the test case is broken, not expand.
(define (ensure-good-test-case o1 o2)
(let ([d1 (syntax-object->datum o1)]
[d2 (syntax-object->datum o2)])
(let ([d1 (syntax->datum o1)]
[d2 (syntax->datum o2)])
(unless (equal? d1 d2)
(error 'compare-objs "bad test case: ~e ~e" d1 d2))))
@ -64,19 +64,16 @@
(define (both? p? o1 o2) (and (p? o1) (p? o2)))
(compare-expansion #''())
(compare-expansion #'(#%datum . 1))
(compare-expansion #'(#%datum . #t))
(compare-expansion #'(quote 1))
(compare-expansion #'(#%top . x))
(compare-expansion #'(if (#%top . a) (#%top . b) (#%top . c)))
(compare-expansion #'(if (#%top . a) (#%top . b)))
(compare-expansion #'(lambda () (#%top . x)))
(compare-expansion #'(lambda (x) x))
(compare-expansion #'(lambda (x y z) x))
(compare-expansion #'(lambda (x) x x x))
(compare-expansion #'(#%plain-lambda () (#%top . x)))
(compare-expansion #'(#%plain-lambda (x) x))
(compare-expansion #'(#%plain-lambda (x y z) x))
(compare-expansion #'(#%plain-lambda (x) x x x))
(compare-expansion #'(case-lambda))
(compare-expansion #'(case-lambda [() (#%datum . 1)]))
(compare-expansion #'(case-lambda [() (#%datum . 1)] [(x) x]))
(compare-expansion #'(case-lambda [() (quote 1)]))
(compare-expansion #'(case-lambda [() (quote 1)] [(x) x]))
(compare-expansion #'(case-lambda [(x y) x]))
(compare-expansion #'(define-values () (#%top . x)))
(compare-expansion #'(define-values (x) (#%top . x)))
@ -84,37 +81,37 @@
(compare-expansion #'(define-syntaxes () (#%top . x)))
(compare-expansion #'(define-syntaxes (s) (#%top . x)))
(compare-expansion #'(define-syntaxes (s x y) (#%top . x)))
(compare-expansion #'(require mzscheme))
(compare-expansion #'(require (lib "list.ss")))
(compare-expansion #'(require (lib "list.ss") mzscheme))
(compare-expansion #'(require-for-syntax mzscheme))
(compare-expansion #'(require-for-syntax (lib "list.ss")))
(compare-expansion #'(require-for-syntax (lib "list.ss") mzscheme))
(compare-expansion #'(#%require mzscheme))
(compare-expansion #'(#%require (lib "list.ss")))
(compare-expansion #'(#%require (lib "list.ss") mzscheme))
(compare-expansion #'(#%require (for-syntax mzscheme)))
(compare-expansion #'(#%require (for-syntax (lib "list.ss"))))
(compare-expansion #'(#%require (for-syntax (lib "list.ss") mzscheme)))
(compare-expansion #'(begin))
(compare-expansion #'(begin (#%top . x)))
(compare-expansion #'(begin (#%top . x) (#%datum . 2)))
(compare-expansion #'(begin (#%top . x) (quote 2)))
(compare-expansion #'(begin0 (#%top . x)))
(compare-expansion #'(begin0 (#%top . x) (#%datum . 2)))
(compare-expansion #'(begin0 (#%top . x) (#%datum . 2) (#%datum . 2)))
(compare-expansion #'(begin0 (#%top . x) (quote 2)))
(compare-expansion #'(begin0 (#%top . x) (quote 2) (quote 2)))
(compare-expansion #'(let-values () (#%top . q)))
(compare-expansion #'(let-values (((x y) (#%top . p))) (#%top . q)))
(compare-expansion #'(let-values (((x y) (#%top . p)) ((z) (#%datum . 12))) (#%top . q)))
(compare-expansion #'(let-values (((x y) (#%top . p)) ((z) (quote 12))) (#%top . q)))
(compare-expansion #'(let-values (((x y) (#%top . p))) (#%top . q) (#%top . p)))
(compare-expansion #'(letrec-values () (#%top . q)))
(compare-expansion #'(letrec-values (((x y) (#%top . p))) (#%top . q)))
(compare-expansion #'(letrec-values (((x y) (#%top . p)) ((z) (#%datum . 12))) (#%top . q)))
(compare-expansion #'(letrec-values (((x y) (#%top . p)) ((z) (quote 12))) (#%top . q)))
(compare-expansion #'(letrec-values (((x y) (#%top . p))) (#%top . q) (#%top . p)))
(compare-expansion #'(set! x (#%top . y)))
(compare-expansion #'(quote-syntax x))
(compare-expansion #'(with-continuation-mark (#%top . x) (#%top . x) (#%top . x)))
(compare-expansion #'(#%app (#%top . f)))
(compare-expansion #'(#%app (#%top . f) (#%datum . 1))))
(compare-expansion #'(#%plain-app (#%top . f)))
(compare-expansion #'(#%plain-app (#%top . f) (quote 1))))
(define expand-test-use-toplevel? #f)
(define datum->top-level-syntax-object
(define datum->top-level-syntax
(lambda (v)
(namespace-syntax-introduce (datum->syntax-object #f v))))
(namespace-syntax-introduce (datum->syntax #f v))))
(define now-expanding (make-parameter #f))
@ -139,13 +136,13 @@
(let ([x (if (or (compiled-expression? x)
(and (syntax? x) (compiled-expression? (syntax-e x))))
x
(parameterize ([current-module-name-prefix #f]
(parameterize ([current-module-declare-name #f]
[now-expanding expand-test-use-toplevel?])
(expand-syntax
((if expand-test-use-toplevel?
expand-top-level-with-compile-time-evals
expand-syntax)
((if (syntax? x) values datum->top-level-syntax-object) x)))))])
((if (syntax? x) values datum->top-level-syntax) x)))))])
(set! mz-test-syntax-errors-allowed? #f)
(orig x)))))))
(lambda ()

61
collects/tests/mzscheme/macro.ss
View File

@ -339,4 +339,65 @@
;; ----------------------------------------
(require (only-in mzlib/etc begin-with-definitions))
(define-syntax (def stx)
(syntax-case stx ()
[(_ id)
(with-syntax ([x:id (datum->syntax #'id 'x)])
#'(begin
(define x:id 50)
(define-syntax id #'x:id)))]))
(define-syntax (look stx)
(syntax-case stx ()
[(_ id) (syntax-local-value #'id)]))
(test 50 'look
(let ()
(def foo)
(look foo)))
(test 50 'look
(begin-with-definitions
(def foo)
(look foo)))
(test #t 'bwd-struct
(let ()
(begin-with-definitions
(define-struct a (x y))
(define-struct (b a) (z))
(b? (make-b 1 2 3)))))
(test 5 'intdef
(let ()
(define-syntax foo
(syntax-rules ()
[(_ id) (begin
(define x 5)
(define id x))]))
(foo x)
x))
(test 6 'intdef-values
(let ()
(define-syntax foo
(syntax-rules ()
[(_ id) (define-values (x id)
(values 6 (lambda () x)))]))
(foo x)
(x)))
(test 75 'bwd
(begin-with-definitions
(define-syntax foo
(syntax-rules ()
[(_ id) (begin
(define x 75)
(define id x))]))
(foo x)
x))
;; ----------------------------------------
(report-errs)

4
collects/tests/mzscheme/module.ss
View File

@ -239,6 +239,8 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test proper bindings for `#%module-begin'
(define expand-test-use-toplevel? #t)
(test (void) eval
'(begin
(module mod_beg2 mzscheme
@ -282,6 +284,8 @@
(module m 'mod_beg2
3)))
(define expand-test-use-toplevel? #f)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ([f1 "tmp1.ss"]

2
collects/tests/mzscheme/syntax.ss
View File

@ -1156,9 +1156,11 @@
[(_) (+ 2 (abcdefg 9))]
[(_ ?) 77])])
(abcdefg))))
(define expand-test-use-toplevel? #t)
(splicing-let-syntax ([abcdefg (syntax-rules ()
[(_) 8])])
(define hijklmn (abcdefg)))
(define expand-test-use-toplevel? #f)
(test 8 'hijklmn hijklmn)
(test 30 'local-hijklmn (let ()
(splicing-let-syntax ([abcdefg (syntax-rules ()

12
collects/tests/units/test-unit.ss
View File

@ -1677,3 +1677,15 @@
(use-unit-badly1 u-a))
(test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a"
(use-unit-badly2 sig^))
(test 12
(let ()
(define-signature s^ (x))
(define-unit u@
(import)
(export s^)
(define x 12))
(define-values/invoke-unit u@ (import) (export s^))
x))

4
collects/tests/web-server/template/examples/blog-posted.html Normal file
View File

@ -0,0 +1,4 @@
<h2>@|title|</h2>
<p>@|body|</p>
<h1><a href="@|k-url|">Continue</a></h1>

16
collects/tests/web-server/template/examples/blog-posts.html Normal file
View File

@ -0,0 +1,16 @@
@in[p posts]{
<h2>@(post-title p)</h2>
<p>@(post-body p)</p>
<ul>
@in[c (post-comments p)]{
<li>@|c|</li>
}
</ul>
}
<h1>New Post</h1>
<form action="@|k-url|">
<input name="title" />
<input name="body" />
<input type="submit" />
</form>

93
collects/tests/web-server/template/examples/blog-xexpr.ss Normal file
View File

@ -0,0 +1,93 @@
#lang scheme
(require web-server/servlet
xml
web-server/servlet-env)
(define-struct post (title body comments))
(define posts
(list
(make-post
"(Y Y) Works: The Why of Y"
"..."
(list
"First post! - A.T."
"Didn't I write this? - Matthias"))
(make-post
"Church and the States"
"As you may know, I grew up in DC, not technically a state..."
(list
"Finally, A Diet That Really Works! As Seen On TV"))))
(define (template section body)
`(html
(head (title "Alonzo's Church: " ,section)
(style ([type "text/css"])
,(make-cdata #f #f "
body {
margin: 0px;
padding: 10px;
}
#main {
background: #dddddd;
}")))
(body
(script ([type "text/javascript"])
,(make-cdata #f #f "
var gaJsHost = ((\"https:\" == document.location.protocol) ?
\"https://ssl.\" : \"http://www.\");
document.write(unescape(\"%3Cscript src='\" + gaJsHost +
\"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\"));
"))
(script ([type "text/javascript"])
,(make-cdata #f #f "
var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");
pageTracker._trackPageview();
"))
(h1 "Alonzo's Church: " ,section)
(div ([id "main"])
,@body))))
(define (blog-posted title body k-url)
`((h2 ,title)
(p ,body)
(h1 (a ([href ,k-url]) "Continue"))))
(define (extract-post req)
(define title (extract-binding/single 'title (request-bindings req)))
(define body (extract-binding/single 'body (request-bindings req)))
(set! posts
(list* (make-post title body empty)
posts))
(send/suspend
(lambda (k-url)
(template "Posted" (blog-posted title body k-url))))
(display-posts))
(define (blog-posts k-url)
(append
(apply append
(for/list ([p posts])
`((h2 ,(post-title p))
(p ,(post-body p))
(ul
,@(for/list ([c (post-comments p)])
`(li ,c))))))
`((h1 "New Post")
(form ([action ,k-url])
(input ([name "title"]))
(input ([name "body"]))
(input ([type "submit"]))))))
(define (display-posts)
(extract-post
(send/suspend
(lambda (k-url)
(template "Posts" (blog-posts k-url))))))
(define (start req)
(display-posts))
(serve/servlet start)

32
collects/tests/web-server/template/examples/blog.html Normal file
View File

@ -0,0 +1,32 @@
<html>
<head>
<title>Alonzo's Church: @|section|</title>
<style type="text/css">
body {
margin: 0px;
padding: 10px;
}
#main {
background: #dddddd;
}
</style>
</head>
<body>
<script type="text/javascript">
var gaJsHost = (("https:" == document.location.protocol) ?
"https://ssl." : "http://www.");
document.write(unescape("%3Cscript src='" + gaJsHost +
"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));
</script>
<script type="text/javascript">
var pageTracker = _gat._getTracker("UA-YYYYYYY-Y");
pageTracker._trackPageview();
</script>
<h1>Alonzo's Church: @|section|</h1>
<div id="main">
@body
</div>
</body>
</html>

46
collects/tests/web-server/template/examples/blog.ss Normal file
View File

@ -0,0 +1,46 @@
#lang scheme
(require web-server/templates
web-server/servlet
web-server/servlet-env)
(define-struct post (title body comments))
(define posts
(list
(make-post
"(Y Y) Works: The Why of Y"
"..."
(list
"First post! - A.T."
"Didn't I write this? - Matthias"))
(make-post
"Church and the States"
"As you may know, I grew up in DC, not technically a state..."
(list
"Finally, A Diet That Really Works! As Seen On TV"))))
(define (template section body)
(list TEXT/HTML-MIME-TYPE
(include-template "blog.html")))
(define (extract-post req)
(define title (extract-binding/single 'title (request-bindings req)))
(define body (extract-binding/single 'body (request-bindings req)))
(set! posts
(list* (make-post title body empty)
posts))
(send/suspend
(lambda (k-url)
(template "Posted" (include-template "blog-posted.html"))))
(display-posts))
(define (display-posts)
(extract-post
(send/suspend
(lambda (k-url)
(template "Posts" (include-template "blog-posts.html"))))))
(define (start req)
(display-posts))
(serve/servlet start)

8
collects/typed-scheme/private/base-env.ss
View File

@ -3,6 +3,7 @@
(require
scheme/list
scheme/tcp
scheme
(only-in rnrs/lists-6 fold-left)
'#%paramz
(only-in '#%kernel [apply kernel:apply])
@ -493,4 +494,9 @@
[tcp-close (-TCP-Listener . -> . -Void )]
[tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
[tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
[tcp-listen (N . -> . -TCP-Listener)]
[tcp-listen (N . -> . -TCP-Listener)]
;; scheme/bool
[boolean=? (B B . -> . B)]
[symbol=? (Sym Sym . -> . B)]
[false? (make-pred-ty (-val #f))]

2
collects/web-server/dispatchers/dispatch-log.ss
View File

@ -45,7 +45,7 @@
(define (apache-default-format req)
(define request-time (srfi-date:current-date))
(format "~a - - [~a] \"~a\" ~a ~a~n"
(request-host-ip req)
(request-client-ip req)
(srfi-date:date->string request-time "~d/~b/~Y:~T ~z")
(request-line-raw req)
200

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

@ -110,15 +110,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
"conf"
"not-found.html"))]
[#:mime-types-path mime-types-path path?
(let ([p (build-path
server-root-path
"mime.types")])
(if (file-exists? p)
p
(build-path
(directory-part
default-configuration-table-path)
"mime.types")))]
...]
[#:log-file log-file path? #f]
[#:log-format log-format symbol? 'apache-default])
void]{
@ -157,8 +149,10 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
If @scheme[banner?] is true, then an informative banner is printed. You may want to use this when
running from the command line, in which case the @scheme[command-line?] option controls similar options.
MIME types are looked up at @scheme[mime-types-path].
MIME types are looked up at @scheme[mime-types-path]. By default the @filepath{mime.types} file in the
@scheme[server-root-path] is used, but if that file does not exist, then the file that ships with the
Web Server is used instead. Of course, if a path is given, then it overrides this behavior.
If @scheme[log-file] is given, then it used to log requests using @scheme[log-format] as the format. Allowable formats
are those allowed by @scheme[log-format->format].
}

296
collects/web-server/scribblings/templates.scrbl
View File

@ -2,11 +2,13 @@
@(require "web-server.ss")
@(require (for-label web-server/servlet
web-server/templates
scheme/promise
scheme/list
xml))
@(define xexpr @tech[#:doc '(lib "xml/xml.scrbl")]{X-expression})
@(define at-reader-ref @secref[#:doc '(lib "scribblings/scribble/scribble.scrbl")]{reader})
@(define text-ref @secref[#:doc '(lib "scribblings/scribble/scribble.scrbl")]{preprocessor})
@title[#:tag "templates"]{Templates}
@ -15,6 +17,9 @@
The @web-server provides a powerful Web template system for separating the presentation logic of a Web application
and enabling non-programmers to contribute to PLT-based Web applications.
@margin-note{Although all the examples here generate HTML, the template language and the @text-ref it is based on can
be used to generate any text-based format: C, SQL, form emails, reports, etc.}
@local-table-of-contents[]
@section{Static}
@ -62,8 +67,8 @@ Then
]
evaluates to the same content as the static example.
There is no constraints on the values, the way they are used, or the way they are defined, that are made accessible to the template.
For example,
There are no constraints on how the lexical context of the template is populated. For instance, you can built template abstractions
by wrapping the inclusion of a template in a function:
@schemeblock[
(define (fast-template thing)
(include-template "simple.html"))
@ -94,18 +99,71 @@ and
</html>
}|
Furthermore, there are no constraints on the Scheme used by templates: they can use macros, structs, continuation marks, threads, etc.
However, Scheme values that are ultimately returned must be printable by the @text-ref@"."
For example, consider the following outputs of the
title line of different calls to @scheme[fast-template]:
@itemize{
@item{
@schemeblock[
(fast-template 'Templates)
]
@verbatim[#:indent 2]|{
<head><title>Fastest Templates in the West!</title></head>
}|
}
@item{
@schemeblock[
(fast-template 42)
]
@verbatim[#:indent 2]|{
<head><title>Fastest 42 in the West!</title></head>
}|
}
@item{
@schemeblock[
(fast-template (list "Noo" "dles"))
]
@verbatim[#:indent 2]|{
<head><title>Fastest Noodles in the West!</title></head>
}|
}
@item{
@schemeblock[
(fast-template (lambda () "Thunks"))
]
@verbatim[#:indent 2]|{
<head><title>Fastest Thunks in the West!</title></head>
}|
}
@item{
@schemeblock[
(fast-template (delay "Laziness"))
]
@verbatim[#:indent 2]|{
<head><title>Fastest Laziness in the West!</title></head>
}|
}
}
@section{Gotchas}
One of the most important things to remember about the @at-reader-ref syntax is that the @"@" symbol must be escaped in content:
To obtain an @"@" symbol in template output, you must escape the @"@" symbol, because it is the escape character of the @at-reader-ref syntax.
For example, to obtain:
@verbatim[#:indent 2]|{
<html>
<head><title>Fastest @"@"s in the West!</title></head>
<body>
<h1>Bang!</h1>
<h2>Bang!</h2>
</body>
</html>
<head><title>Fastest @s in the West!</title></head>
}|
You must write:
@verbatim[#:indent 2]|{
<head><title>Fastest @"@"s in the West!</title></head>
}|
as your template: literal @"@"s must be replaced with @"@\"@\"".
The other gotcha is that since the template is compiled into a Scheme program, only its results will be printed. For example, suppose
we have the template:
@ -117,7 +175,7 @@ we have the template:
</table>
}|
If this is included in a lexical context with @scheme[clients] bound to @scheme[(list (cons "Young" "Brigham") (cons "Smith" "Joseph"))],
If this is included in a lexical context with @scheme[clients] bound to @schemeblock[(list (cons "Young" "Brigham") (cons "Smith" "Joseph"))]
then the template will be printed as:
@verbatim[#:indent 2]|{
<table>
@ -225,4 +283,218 @@ the template to be unescaped, then create a @scheme[cdata] structure:
(in c clients "<tr><td>" (car c) ", " (cdr c) "</td></tr>")
]
}
@section{Conversion Example}
Alonzo Church has been maintaining a blog with PLT Scheme for some years and would like to convert to @schememodname[web-server/templates].
Here's the code he starts off with:
@schememod[
scheme
(require xml
web-server/servlet
web-server/servlet-env)
(code:comment "He actually Church-encodes them, but we'll use structs.")
(define-struct post (title body comments))
(define posts
(list
(make-post
"(Y Y) Works: The Why of Y"
"..."
(list
"First post! - A.T."
"Didn't I write this? - Matthias"))
(make-post
"Church and the States"
"As you may know, I grew up in DC, not technically a state..."
(list
"Finally, A Diet That Really Works! As Seen On TV"))))
(code:comment "A function that is the generic template for the site")
(define (template section body)
`(html
(head (title "Alonzo's Church: " ,section)
(style ([type "text/css"])
(code:comment "CDATA objects were useful for returning raw data")
,(make-cdata #f #f "\n body {\n margin: 0px;\n padding: 10px;\n }\n\n #main {\n background: #dddddd;\n }")))
(body
(script ([type "text/javascript"])
(code:comment "Which is particularly useful for JavaScript")
,(make-cdata #f #f "\n var gaJsHost = ((\"https:\" == document.location.protocol) ?\n \"https://ssl.\" : \"http://www.\");\n document.write(unescape(\"%3Cscript src='\" + gaJsHost +\n \"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\"));\n"))
(script ([type "text/javascript"])
,(make-cdata #f #f "\n var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");\n pageTracker._trackPageview();\n"))
(h1 "Alonzo's Church: " ,section)
(div ([id "main"])
(code:comment "He had to be careful to use splicing here")
,@body))))
(define (blog-posted title body k-url)
`((h2 ,title)
(p ,body)
(h1 (a ([href ,k-url]) "Continue"))))
(define (extract-post req)
(define binds
(request-bindings req))
(define title
(extract-binding/single 'title binds))
(define body
(extract-binding/single 'body binds))
(set! posts
(list* (make-post title body empty)
posts))
(send/suspend
(lambda (k-url)
(template "Posted" (blog-posted title body k-url))))
(display-posts))
(define (blog-posts k-url)
(code:comment "append or splicing is needed")
(append
(code:comment "Each element of the list is another list")
(apply append
(for/list ([p posts])
`((h2 ,(post-title p))
(p ,(post-body p))
(ul
,@(for/list ([c (post-comments p)])
`(li ,c))))))
`((h1 "New Post")
(form ([action ,k-url])
(input ([name "title"]))
(input ([name "body"]))
(input ([type "submit"]))))))
(define (display-posts)
(extract-post
(send/suspend
(lambda (k-url)
(template "Posts" (blog-posts k-url))))))
(define (start req)
(display-posts))
(serve/servlet start)
]
Luckily, Alonzo has great software engineering skills, so he's already separated the presentation logic into the functions
@scheme[blog-posted], @scheme[blog-posts], and @scheme[template]. Each one of these will turn into a different
template.
@filepath{blog.html}:
@verbatim[#:indent 2]|{
<html>
<head>
<title>Alonzo's Church: @|section|</title>
<style type="text/css">
body {
margin: 0px;
padding: 10px;
}
#main {
background: #dddddd;
}
</style>
</head>
<body>
<script type="text/javascript">
var gaJsHost = (("https:" == document.location.protocol) ?
"https://ssl." : "http://www.");
document.write(unescape("%3Cscript src='" + gaJsHost +
"google-analytics.com/ga.js'
type='text/javascript'%3E%3C/script%3E"));
</script>
<script type="text/javascript">
var pageTracker = _gat._getTracker("UA-YYYYYYY-Y");
pageTracker._trackPageview();
</script>
<h1>Alonzo's Church: @|section|</h1>
<div id="main">
@body
</div>
</body>
</html>
}|
Notice that this part of the presentation is much simpler, because the CSS and JavaScript
can be included verbatim, without resorting to any special escape-escaping patterns.
Similarly, since the @scheme[body] is represented as a string, there is no need to
remember if splicing is necessary.
@filepath{blog-posts.html}:
@verbatim[#:indent 2]|{
@in[p posts]{
<h2>@(post-title p)</h2>
<p>@(post-body p)</p>
<ul>
@in[c (post-comments p)]{
<li>@|c|</li>
}
</ul>
}
<h1>New Post</h1>
<form action="@|k-url|">
<input name="title" />
<input name="body" />
<input type="submit" />
</form>
}|
This template is even simpler, because there is no list management whatsoever. The defaults "just work".
For completeness, we show the final template:
@filepath{blog-posted.html}:
@verbatim[#:indent 2]|{
<h2>@|title|</h2>
<p>@|body|</p>
<h1><a href="@|k-url|">Continue</a></h1>
}|
The code associated with these templates is very simple as well:
@schememod[
scheme
(require web-server/templates
web-server/servlet
web-server/servlet-env)
(define-struct post (title body comments))
(define posts ...)
(define (template section body)
(list TEXT/HTML-MIME-TYPE
(include-template "blog.html")))
(define (extract-post req)
(define binds
(request-bindings req))
(define title
(extract-binding/single 'title binds))
(define body
(extract-binding/single 'body binds))
(set! posts
(list* (make-post title body empty)
posts))
(send/suspend
(lambda (k-url)
(template "Posted" (include-template "blog-posted.html"))))
(display-posts))
(define (display-posts)
(extract-post
(send/suspend
(lambda (k-url)
(template "Posts" (include-template "blog-posts.html"))))))
(define (start req)
(display-posts))
(serve/servlet start)
]

6
src/mred/wxs/wxscheme.cxx
View File

@ -162,10 +162,8 @@ void wxsScheme_setup(Scheme_Env *env)
get_ps_setup_from_user = scheme_false;
message_box = scheme_false;
orig_collect_start_callback = GC_collect_start_callback;
GC_collect_start_callback = (GC_START_END_PTR)collect_start_callback;
orig_collect_end_callback = GC_collect_end_callback;
GC_collect_end_callback = (GC_START_END_PTR)collect_end_callback;
orig_collect_start_callback = GC_set_collect_start_callback(collect_start_callback);
orig_collect_end_callback = GC_set_collect_end_callback(collect_end_callback);
}
extern "C" {

16
src/mzscheme/gc/alloc.c
View File

@ -320,8 +320,20 @@ void GC_maybe_gc()
}
/* PLTSCHEME: notification callback for starting/ending a GC */
void (*GC_collect_start_callback)(void) = NULL;
void (*GC_collect_end_callback)(void) = NULL;
GC_collect_start_callback_Proc GC_collect_start_callback = NULL;
GC_collect_end_callback_Proc GC_collect_end_callback = NULL;
GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) {
GC_collect_start_callback_Proc old;
old = GC_collect_start_callback;
GC_collect_start_callback = func;
return old;
}
GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) {
GC_collect_end_callback_Proc old;
old = GC_collect_end_callback;
GC_collect_end_callback = func;
return old;
}
/*
* Stop the world garbage collection. Assumes lock held, signals disabled.

6
src/mzscheme/gc/include/gc.h
View File

@ -1017,13 +1017,15 @@ extern void GC_thr_init GC_PROTO((void));/* Needed for Solaris/X86 */
#if defined(GC_REDIRECT_TO_LOCAL) && !defined(GC_LOCAL_ALLOC_H)
# include "gc_local_alloc.h"
#endif
typedef void (*GC_collect_start_callback_Proc)(void);
typedef void (*GC_collect_end_callback_Proc)(void);
/* PLTSCHEME: */
GC_API void (*GC_custom_finalize)(void);
GC_API void (*GC_push_last_roots)(void);
GC_API void (*GC_push_last_roots_again)(void);
GC_API void (*GC_collect_start_callback)(void);
GC_API void (*GC_collect_end_callback)(void);
GC_API GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc);
GC_API GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc);
GC_API void (*GC_out_of_memory)(void);
GC_API int GC_did_mark_stack_overflow(void);
GC_API void GC_mark_from_mark_stack(void);

16
src/mzscheme/gc2/gc2.h
View File

@ -21,6 +21,10 @@
typedef int (*Size_Proc)(void *obj);
typedef int (*Mark_Proc)(void *obj);
typedef int (*Fixup_Proc)(void *obj);
typedef void (*GC_collect_start_callback_Proc)(void);
typedef void (*GC_collect_end_callback_Proc)(void);
typedef void (*GC_collect_inform_callback_Proc)(int major_gc, long pre_used, long post_used);
typedef unsigned long (*GC_get_thread_stack_base_Proc)(void);
/*
Types of the traversal procs (supplied by MzScheme); see overview in README
for information about traversals. The return value is the size of
@ -56,9 +60,9 @@ extern "C" {
/* Administration */
/***************************************************************************/
GC2_EXTERN unsigned long (*GC_get_thread_stack_base)(void);
GC2_EXTERN void GC_set_get_thread_stack_base(unsigned long (*)(void));
/*
Called by GC to get the base for stack traversal in the current
Sets callback called by GC to get the base for stack traversal in the current
thread (see README). The returned address must not be in the middle
of a variable-stack record. */
@ -96,11 +100,11 @@ GC2_EXTERN void GC_register_thread(void *, void *);
/*
Indicates that a a thread record is owned by a particular custodian. */
GC2_EXTERN void (*GC_collect_start_callback)(void);
GC2_EXTERN void (*GC_collect_end_callback)(void);
GC2_EXTERN void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used);
GC2_EXTERN GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc);
GC2_EXTERN GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc);
GC2_EXTERN void GC_set_collect_inform_callback(GC_collect_inform_callback_Proc);
/*
Called by GC before/after performing a collection. Used by MzScheme
Sets callbacks called by GC before/after performing a collection. Used by MzScheme
to zero out some data and record collection times. The end
procedure should be called before finalizations are performed. */

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

@ -130,15 +130,31 @@ static THREAD_LOCAL NewGC *GC;
#define GENERATIONS 1
/* the externals */
void (*GC_collect_start_callback)(void);
void (*GC_collect_end_callback)(void);
void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used);
void (*GC_out_of_memory)(void);
void (*GC_report_out_of_memory)(void);
unsigned long (*GC_get_thread_stack_base)(void);
void (*GC_mark_xtagged)(void *obj);
void (*GC_fixup_xtagged)(void *obj);
GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) {
NewGC *gc = GC_get_GC();
GC_collect_start_callback_Proc old;
old = gc->GC_collect_start_callback;
gc->GC_collect_start_callback = func;
return old;
}
GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) {
NewGC *gc = GC_get_GC();
GC_collect_end_callback_Proc old;
old = gc->GC_collect_end_callback;
gc->GC_collect_end_callback = func;
return old;
}
void GC_set_collect_inform_callback(void (*func)(int major_gc, long pre_used, long post_used)) {
NewGC *gc = GC_get_GC();
gc->GC_collect_inform_callback = func;
}
#include "my_qsort.c"
/*****************************************************************************/
@ -982,8 +998,13 @@ unsigned long GC_get_stack_base()
return gc->stack_base;
}
void GC_set_get_thread_stack_base(unsigned long (*func)(void)) {
NewGC *gc = GC_get_GC();
gc->GC_get_thread_stack_base = func;
}
static inline void *get_stack_base(NewGC *gc) {
if (GC_get_thread_stack_base) return (void*) GC_get_thread_stack_base();
if (gc->GC_get_thread_stack_base) return (void*) gc->GC_get_thread_stack_base();
return (void*) gc->stack_base;
}
@ -2409,8 +2430,8 @@ static void garbage_collect(NewGC *gc, int force_full)
TIME_INIT();
/* inform the system (if it wants us to) that we're starting collection */
if(GC_collect_start_callback)
GC_collect_start_callback();
if(gc->GC_collect_start_callback)
gc->GC_collect_start_callback();
TIME_STEP("started");
@ -2530,10 +2551,10 @@ static void garbage_collect(NewGC *gc, int force_full)
gc->last_full_mem_use = gc->memory_in_use;
/* inform the system (if it wants us to) that we're done with collection */
if (GC_collect_start_callback)
GC_collect_end_callback();
if (GC_collect_inform_callback)
GC_collect_inform_callback(gc->gc_full, old_mem_use + old_gen0, gc->memory_in_use);
if (gc->GC_collect_start_callback)
gc->GC_collect_end_callback();
if (gc->GC_collect_inform_callback)
gc->GC_collect_inform_callback(gc->gc_full, old_mem_use + old_gen0, gc->memory_in_use);
TIME_STEP("ended");

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

@ -151,6 +151,12 @@ typedef struct NewGC {
unsigned long num_minor_collects;
unsigned long num_major_collects;
/* Callbacks */
void (*GC_collect_start_callback)(void);
void (*GC_collect_end_callback)(void);
void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used);
unsigned long (*GC_get_thread_stack_base)(void);
GC_Immobile_Box *immobile_boxes;
/* Common with CompactGC */

19
src/mzscheme/sgc/sgc.c
View File

@ -776,10 +776,25 @@ static long mem_traced;
static long num_chunks;
static long num_blocks;
void (*GC_collect_start_callback)(void);
void (*GC_collect_end_callback)(void);
typedef void (*GC_collect_start_callback_Proc)(void);
typedef void (*GC_collect_end_callback_Proc)(void);
GC_collect_start_callback_Proc GC_collect_start_callback;
GC_collect_end_callback_Proc GC_collect_end_callback;
void (*GC_custom_finalize)(void);
GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc) {
GC_collect_start_callback_Proc old;
old = GC_collect_start_callback;
GC_collect_start_callback = func;
return old
}
GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc) {
GC_collect_end_callback_Proc old
old = GC_collect_end_callback;
GC_collect_end_callback = func;
return old
}
static long roots_count;
static long roots_size;
static unsigned long *roots;

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

@ -2123,7 +2123,8 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
}
while (env != upto) {
if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) {
if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME
| SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) {
int i, count;
/* How many slots filled in the frame so far? This can change
@ -2311,6 +2312,26 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
stx = scheme_add_rename(stx, l);
}
}
} else if (env->flags & SCHEME_INTDEF_SHADOW) {
/* Just extract existing uids from identifiers, and don't need to
add renames to syntax objects. */
if (!env->uids) {
Scheme_Object **uids, *uid;
int i;
uids = MALLOC_N(Scheme_Object *, env->num_bindings);
env->uids = uids;
for (i = env->num_bindings; i--; ) {
uid = scheme_stx_moduleless_env(env->values[i]);
if (SCHEME_FALSEP(uid))
scheme_signal_error("intdef shadow binding is #f for %d/%s",
SCHEME_TYPE(env->values[i]),
scheme_write_to_string(SCHEME_STX_VAL(env->values[i]),
NULL));
env->uids[i] = uid;
}
}
}
env = env->next;
@ -2446,7 +2467,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (frame->values[i]) {
if (frame->uids)
uid = frame->uids[i];
if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i]))
if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i]))
&& (scheme_stx_env_bound_eq(find_id, frame->values[i], uid, scheme_make_integer(phase))
|| ((frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)
&& scheme_stx_module_eq2(find_id, frame->values[i], scheme_make_integer(phase), find_id_sym))

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

@ -778,7 +778,7 @@ scheme_signal_error (const char *msg, ...)
if (scheme_current_thread->current_local_env) {
char *s2 = " [during expansion]";
strcpy(buffer + len, s2);
len = strlen(s2);
len += strlen(s2);
}
buffer[len] = 0;

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

@ -4563,6 +4563,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
/* should be always NULL */
dest[i].observer = src[drec].observer;
dest[i].pre_unwrapped = 0;
dest[i].env_already = 0;
}
}
@ -4581,6 +4582,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec,
dest[i].certs = src[drec].certs;
dest[i].observer = src[drec].observer;
dest[i].pre_unwrapped = 0;
dest[i].env_already = 0;
}
}
@ -4603,6 +4605,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec,
lam[dlrec].certs = src[drec].certs;
lam[dlrec].observer = src[drec].observer;
lam[dlrec].pre_unwrapped = 0;
lam[dlrec].env_already = 0;
}
void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec,
@ -4850,6 +4853,7 @@ static void *compile_k(void)
rec.certs = NULL;
rec.observer = NULL;
rec.pre_unwrapped = 0;
rec.env_already = 0;
cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);
@ -6289,7 +6293,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (!SCHEME_STX_SYMBOLP(var))
scheme_wrong_syntax(NULL, var, first,
"name must be an identifier");
scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
// scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
vars = SCHEME_STX_CDR(vars);
cnt++;
}
@ -6359,6 +6363,16 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
scheme_set_local_syntax(cnt++, a, scheme_false, new_env);
}
/* Extend shared rib with renamings */
scheme_add_env_renames(rib, new_env, env);
/* Check for duplicates after extending the rib with renamings,
since the renamings properly track marks. */
for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
a = SCHEME_STX_CAR(l);
scheme_dup_symbol_check(&r, "internal definition", a, "binding", first);
}
if (!is_val) {
/* Evaluate and bind syntaxes */
scheme_prepare_exp_env(new_env->genv);
@ -6371,9 +6385,6 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
&pos);
}
/* Extend shared rib with renamings */
scheme_add_env_renames(rib, new_env, env);
/* Remember extended environment */
SCHEME_PTR1_VAL(ctx) = new_env;
env = new_env;
@ -6441,6 +6452,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
}
if (!more) {
/* We've converted to a letrec or letrec-values+syntaxes */
rec[drec].env_already = 1;
if (rec[drec].comp) {
result = scheme_compile_expr(result, env, rec, drec);
return scheme_make_pair(result, scheme_null);
@ -8720,6 +8734,7 @@ static void *expand_k(void)
erec1.certs = certs;
erec1.observer = observer;
erec1.pre_unwrapped = 0;
erec1.env_already = 0;
if (catch_lifts_key)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
@ -9201,7 +9216,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
l = scheme_add_rename(l, renaming);
if (for_expr) {
/* Package up expanded expr with the enviornment. */
/* Package up expanded expr with the environment. */
while (1) {
if (orig_env->flags & SCHEME_FOR_STOPS)
orig_env = orig_env->next;
@ -9552,6 +9567,7 @@ local_eval(int argc, Scheme_Object **argv)
rec.certs = certs;
rec.observer = observer;
rec.pre_unwrapped = 0;
rec.env_already = 0;
/* Evaluate and bind syntaxes */
expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);

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

@ -5773,6 +5773,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
erec1.certs = rec[drec].certs;
erec1.observer = rec[drec].observer;
erec1.pre_unwrapped = 0;
erec1.env_already = 0;
e = scheme_expand_expr(e, xenv, &erec1, 0);
}
@ -5975,6 +5976,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
mrec.certs = rec[drec].certs;
mrec.observer = NULL;
mrec.pre_unwrapped = 0;
mrec.env_already = 0;
if (!rec[drec].comp) {
Scheme_Expand_Info erec1;
@ -5984,6 +5986,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
erec1.certs = rec[drec].certs;
erec1.observer = rec[drec].observer;
erec1.pre_unwrapped = 0;
erec1.env_already = 0;
SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
}

7
src/mzscheme/src/port.c
View File

@ -892,9 +892,6 @@ typedef struct Scheme_Thread_Memory {
Scheme_Thread_Memory *tm_start, *tm_next;
extern MZ_DLLIMPORT void (*GC_collect_start_callback)(void);
extern MZ_DLLIMPORT void (*GC_collect_end_callback)(void);
void scheme_init_thread_memory()
{
#ifndef MZ_PRECISE_GC
@ -915,8 +912,8 @@ void scheme_init_thread_memory()
#endif
/* scheme_init_thread() will replace these: */
GC_collect_start_callback = scheme_suspend_remembered_threads;
GC_collect_end_callback = scheme_resume_remembered_threads;
GC_set_collect_start_callback(scheme_suspend_remembered_threads);
GC_set_collect_end_callback(scheme_resume_remembered_threads);
}
Scheme_Thread_Memory *scheme_remember_thread(void *t, int autoclose)

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

@ -4371,8 +4371,6 @@ static Scheme_Object *read_compact_k(void)
return read_compact(port, p->ku.k.i1);
}
int dump_info = 0;
static Scheme_Object *read_compact(CPort *port, int use_stack)
{
#define BLK_BUF_SIZE 32
@ -4398,9 +4396,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
ZO_CHECK(port->pos < port->size);
ch = CP_GETC(port);
if (dump_info)
printf("%d %d %d\n", ch, port->pos, need_car);
switch(cpt_branch[ch]) {
case CPT_ESCAPE:
{
@ -4456,8 +4451,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
case CPT_SYMREF:
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
if (dump_info)
printf("%d\n", l);
v = port->symtab[l];
if (!v) {
long save_pos = port->pos;
@ -5268,7 +5261,6 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
len = symtabsize;
for (j = 1; j < len; j++) {
if (!symtab[j]) {
if (dump_info) printf("at %ld %ld\n", j, rp->pos);
v = read_compact(rp, 0);
symtab[j] = v;
} else {

2
src/mzscheme/src/salloc.c
View File

@ -2053,7 +2053,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
scheme_console_printf(" swapped in\n");
var_stack = GC_variable_stack;
delta = 0;
limit = (void *)GC_get_thread_stack_base();
limit = (void *)scheme_get_current_thread_stack_start();
} else {
scheme_console_printf(" swapped out\n");
var_stack = (void **)t->jmpup_buf.gc_var_stack;

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

@ -1837,6 +1837,7 @@ typedef struct Scheme_Compile_Expand_Info
char resolve_module_ids;
char pre_unwrapped;
int depth;
int env_already;
} Scheme_Compile_Expand_Info;
typedef Scheme_Compile_Expand_Info Scheme_Compile_Info;
@ -2301,6 +2302,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
#define SCHEME_FOR_STOPS 128
#define SCHEME_FOR_INTDEF 256
#define SCHEME_CAPTURE_LIFTED 512
#define SCHEME_INTDEF_SHADOW 1024
/* Flags used with scheme_static_distance */
#define SCHEME_ELIM_CONST 1

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

@ -2982,12 +2982,14 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
return scheme_false;
}
XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
Scheme_Object *barrier_env, Scheme_Object *ignore_rib)
XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
/* Compares the marks in two wraps lists. A result of 2 means that the
result depended on a barrier env. Use #f for barrier_env
to treat no rib envs as barriers; we check for barrier_env only in ribs
because simpliciation eliminates the need for these checks(?). */
result depended on a barrier env. For a rib-based renaming, we need
to check only up to the rib, and the barrier effect important for
when a rib-based renaming is layered with another renaming (such as
when an internal-definition-base local-expand is used to form a new
set of bindings, as in the unit form); simplification cleans up the
layers, so that we only need to check in ribs. */
{
WRAP_POS awl;
WRAP_POS bwl;
@ -3015,9 +3017,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
WRAP_POS_INC(awl);
}
} else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) {
if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(awl))) {
WRAP_POS_INC(awl);
} else if (SCHEME_FALSEP(barrier_env)) {
if (SCHEME_FALSEP(barrier_env)) {
WRAP_POS_INC(awl);
} else {
/* See if the barrier environment is in this rib. */
@ -3054,9 +3054,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
WRAP_POS_INC(bwl);
}
} else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) {
if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(bwl))) {
WRAP_POS_INC(bwl);
} else if (SCHEME_FALSEP(barrier_env)) {
if (SCHEME_FALSEP(barrier_env)) {
WRAP_POS_INC(bwl);
} else {
/* See if the barrier environment is in this rib. */
@ -3665,15 +3663,16 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
&& !no_lexical)) {
/* Lexical rename: */
Scheme_Object *rename, *renamed;
int ri, c, istart, iend, is_rib;
int ri, c, istart, iend;
Scheme_Lexical_Rib *is_rib;
if (rib) {
rename = rib->rename;
is_rib = rib;
rib = rib->next;
is_rib = 1;
} else {
rename = WRAP_POS_FIRST(wraps);
is_rib = 0;
is_rib = NULL;
}
c = SCHEME_RENAME_LEN(rename);
@ -3735,7 +3734,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
{
WRAP_POS w2;
WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
same = same_marks(&w2, &wraps, other_env, WRAP_POS_FIRST(wraps));
same = same_marks(&w2, &wraps, other_env);
if (!same)
EXPLAIN(printf("Different marks\n"));
}
@ -3755,7 +3754,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
o_rename_stack = CONS(CONS(other_env, envname),
o_rename_stack);
}
rib = NULL; /* skip rest of rib (if any) */
if (is_rib) {
/* skip rest of rib (if any) and future instances of the same rib */
rib = NULL;
skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs);
}
}
break;
@ -4092,7 +4095,7 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
WRAP_POS bw;
WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps);
if (!same_marks(&aw, &bw, ae, NULL))
if (!same_marks(&aw, &bw, ae))
return 0;
}
@ -4277,7 +4280,7 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *re
WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
if (!same_marks(&aw, &bw, NULL, NULL)) {
if (!same_marks(&aw, &bw, scheme_false)) {
Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps;
if (uid) {
/* Add a rename record: */
@ -4647,7 +4650,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
/* Check marks (now that we have the correct barriers). */
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
if (!same_marks(&w2, &w, other_env, (Scheme_Object *)init_rib)) {
if (!same_marks(&w2, &w, other_env)) {
other_env = NULL;
}
@ -4699,7 +4702,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
}
} else {
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
if (same_marks(&w2, &w, scheme_false, (Scheme_Object *)init_rib))
if (same_marks(&w2, &w, scheme_false))
ok = SCHEME_VEC_ELS(v)[0];
else
ok = NULL;
@ -6759,7 +6762,7 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv)
WRAP_POS_INIT(awl, stx->wraps);
WRAP_POS_INIT_END(ewl);
if (same_marks(&awl, &ewl, scheme_false, NULL))
if (same_marks(&awl, &ewl, scheme_false))
return scheme_true;
else
return scheme_false;

126
src/mzscheme/src/syntax.c
View File

@ -4092,6 +4092,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
Scheme_Object *first = NULL;
Scheme_Compiled_Let_Value *last = NULL, *lv;
DupCheckRecord r;
int rec_env_already = rec[drec].env_already;
i = scheme_stx_proper_list_length(form);
if (i < 3)
@ -4160,8 +4161,14 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
names = MALLOC_N(Scheme_Object *, num_bindings);
if (frame_already)
frame = frame_already;
else
frame = scheme_new_compilation_frame(num_bindings, 0, origenv, rec[drec].certs);
else {
frame = scheme_new_compilation_frame(num_bindings,
(rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
origenv,
rec[drec].certs);
if (rec_env_already)
frame_already = frame;
}
env = frame;
recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1));
@ -4172,7 +4179,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
defname = scheme_check_name_property(form, defname);
if (!star) {
if (!star && !frame_already) {
scheme_begin_dup_symbol_check(&r, env);
}
@ -4216,7 +4223,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
names[k++] = name;
}
if (!star) {
if (!star && !frame_already) {
for (m = pre_k; m < k; m++) {
scheme_dup_symbol_check(&r, NULL, names[m], "binding", form);
}
@ -4319,6 +4326,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
Scheme_Comp_Env *use_env, *env;
Scheme_Expand_Info erec1;
DupCheckRecord r;
int rec_env_already = erec[drec].env_already;
vars = SCHEME_STX_CDR(form);
@ -4385,8 +4393,8 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
}
/* Note: no more letstar handling needed after this point */
scheme_begin_dup_symbol_check(&r, origenv);
if (!env_already && !rec_env_already)
scheme_begin_dup_symbol_check(&r, origenv);
vlist = scheme_null;
vs = vars;
@ -4405,15 +4413,18 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
{
DupCheckRecord r2;
Scheme_Object *names = name;
scheme_begin_dup_symbol_check(&r2, origenv);
if (!env_already && !rec_env_already)
scheme_begin_dup_symbol_check(&r2, origenv);
while (SCHEME_STX_PAIRP(names)) {
name = SCHEME_STX_CAR(names);
scheme_check_identifier(NULL, name, NULL, origenv, form);
vlist = cons(name, vlist);
scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
scheme_dup_symbol_check(&r, NULL, name, "binding", form);
if (!env_already && !rec_env_already) {
scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
scheme_dup_symbol_check(&r, NULL, name, "binding", form);
}
names = SCHEME_STX_CDR(names);
}
@ -4430,7 +4441,10 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
if (env_already)
env = env_already;
else
env = scheme_add_compilation_frame(vlist, origenv, 0, erec[drec].certs);
env = scheme_add_compilation_frame(vlist,
origenv,
(rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
erec[drec].certs);
if (letrec)
use_env = env;
@ -5526,6 +5540,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
rec1.certs = rec[drec].certs;
rec1.observer = NULL;
rec1.pre_unwrapped = 0;
rec1.env_already = 0;
if (for_stx) {
names = defn_targets_syntax(names, exp_env, &rec1, 0);
@ -5717,6 +5732,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
mrec.certs = certs;
mrec.observer = NULL;
mrec.pre_unwrapped = 0;
mrec.env_already = 0;
a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
@ -5805,9 +5821,11 @@ do_letrec_syntaxes(const char *where,
Scheme_Object *form, *bindings, *var_bindings, *body, *v;
Scheme_Object *names_to_disappear;
Scheme_Comp_Env *stx_env, *var_env, *rhs_env;
int cnt, stx_cnt, var_cnt, i, j, depth, saw_var;
int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already;
DupCheckRecord r;
env_already = rec[drec].env_already;
form = SCHEME_STX_CDR(forms);
if (!SCHEME_STX_PAIRP(form))
scheme_wrong_syntax(NULL, NULL, forms, NULL);
@ -5823,7 +5841,10 @@ do_letrec_syntaxes(const char *where,
scheme_rec_add_certs(rec, drec, forms);
stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);
if (env_already)
stx_env = origenv;
else
stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);
rhs_env = stx_env;
@ -5846,8 +5867,8 @@ do_letrec_syntaxes(const char *where,
else
names_to_disappear = NULL;
scheme_begin_dup_symbol_check(&r, stx_env);
if (!env_already)
scheme_begin_dup_symbol_check(&r, stx_env);
/* Pass 1: Check and Rename */
@ -5881,8 +5902,10 @@ do_letrec_syntaxes(const char *where,
for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
a = SCHEME_STX_CAR(l);
scheme_check_identifier(where, a, NULL, stx_env, forms);
scheme_dup_symbol_check(&r, where, a, "binding", forms);
if (!env_already) {
scheme_check_identifier(where, a, NULL, stx_env, forms);
scheme_dup_symbol_check(&r, where, a, "binding", forms);
}
cnt++;
}
if (i)
@ -5895,30 +5918,35 @@ do_letrec_syntaxes(const char *where,
var_cnt = cnt - stx_cnt;
}
scheme_add_local_syntax(stx_cnt, stx_env);
if (saw_var)
var_env = scheme_new_compilation_frame(var_cnt, 0, stx_env, rec[drec].certs);
else
if (!env_already)
scheme_add_local_syntax(stx_cnt, stx_env);
if (saw_var) {
var_env = scheme_new_compilation_frame(var_cnt,
(env_already ? SCHEME_INTDEF_SHADOW : 0),
stx_env,
rec[drec].certs);
} else
var_env = NULL;
for (i = 0; i < (var_env ? 2 : 1) ; i++) {
for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) {
cnt = (i ? var_cnt : stx_cnt);
if (cnt > 0) {
/* Add new syntax names to the environment: */
/* Add new syntax/variable names to the environment: */
j = 0;
for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *l;
Scheme_Object *a, *l;
a = SCHEME_STX_CAR(v);
for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
a = SCHEME_STX_CAR(l);
if (i) {
/* In compile mode, this will get re-written by the letrec compiler.
But that's ok. We need it now for env_renames. */
scheme_add_compilation_binding(j++, a, var_env);
} else
scheme_set_local_syntax(j++, a, NULL, stx_env);
}
a = SCHEME_STX_CAR(v);
for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
a = SCHEME_STX_CAR(l);
if (i) {
/* In compile mode, this will get re-written by the letrec compiler.
But that's ok. We need it now for env_renames. */
scheme_add_compilation_binding(j++, a, var_env);
} else
scheme_set_local_syntax(j++, a, NULL, stx_env);
}
}
}
}
@ -5949,29 +5977,31 @@ do_letrec_syntaxes(const char *where,
scheme_prepare_exp_env(stx_env->genv);
i = 0;
if (!env_already) {
i = 0;
for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *names;
for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *names;
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
a = SCHEME_STX_CAR(v);
names = SCHEME_STX_CAR(a);
a = SCHEME_STX_CDR(a);
a = SCHEME_STX_CAR(a);
a = SCHEME_STX_CAR(v);
names = SCHEME_STX_CAR(a);
a = SCHEME_STX_CDR(a);
a = SCHEME_STX_CAR(a);
scheme_bind_syntaxes(where, names, a,
stx_env->genv->exp_env,
stx_env->insp,
rec, drec,
stx_env, rhs_env,
&i);
scheme_bind_syntaxes(where, names, a,
stx_env->genv->exp_env,
stx_env->insp,
rec, drec,
stx_env, rhs_env,
&i);
}
}
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer);
if (names_to_disappear) {
if (!env_already && names_to_disappear) {
/* Need to add renaming for disappeared bindings. If they
originated for internal definitions, then we need both
pre-renamed and renamed, since some might have been

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

@ -200,10 +200,6 @@ Scheme_Object *scheme_break_enabled_key;
long scheme_total_gc_time;
static long start_this_gc_time, end_this_gc_time;
#ifndef MZ_PRECISE_GC
extern MZ_DLLIMPORT void (*GC_collect_start_callback)(void);
extern MZ_DLLIMPORT void (*GC_collect_end_callback)(void);
#endif
static void get_ready_for_GC(void);
static void done_with_GC(void);
#ifdef MZ_PRECISE_GC
@ -437,7 +433,7 @@ extern BOOL WINAPI DllMain(HINSTANCE inst, ULONG reason, LPVOID reserved);
#endif
#ifdef MZ_PRECISE_GC
static unsigned long get_current_stack_start(void);
unsigned long scheme_get_current_thread_stack_start(void);
#endif
/*========================================================================*/
@ -2106,10 +2102,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
thread_swap_callbacks = scheme_null;
thread_swap_out_callbacks = scheme_null;
GC_collect_start_callback = get_ready_for_GC;
GC_collect_end_callback = done_with_GC;
GC_set_collect_start_callback(get_ready_for_GC);
GC_set_collect_end_callback(done_with_GC);
#ifdef MZ_PRECISE_GC
GC_collect_inform_callback = inform_GC;
GC_set_collect_inform_callback(inform_GC);
#endif
#ifdef LINK_EXTENSIONS_BY_TABLE
@ -2118,7 +2114,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
#endif
#if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC)
GC_get_thread_stack_base = get_current_stack_start;
GC_set_get_thread_stack_base(scheme_get_current_thread_stack_start);
#endif
process->stack_start = stack_base;
@ -7448,7 +7444,7 @@ Scheme_Jumpup_Buf_Holder *scheme_new_jmpupbuf_holder(void)
}
#ifdef MZ_PRECISE_GC
static unsigned long get_current_stack_start(void)
unsigned long scheme_get_current_thread_stack_start(void)
{
Scheme_Thread *p;
p = scheme_current_thread;