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

369.9

Browse Source 
svn: r5902
This commit is contained in:
Matthew Flatt 2007-04-09 08:34:00 +00:00
parent a2376f4980
commit 34d00a000c
21 changed files with 1669 additions and 1499 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/compiler/private/xform.ss
View File

@ -687,15 +687,22 @@
(printf "#define __xform_nongcing__ /**/~n")
;; Another annotation to protect against GC conversion:
(printf "#define HIDE_FROM_XFORM(x) x~n")
(printf "#define XFORM_HIDE_EXPR(x) x~n")
(printf "#define HIDE_NOTHING_FROM_XFORM() /**/~n")
;; In case a conversion is unnecessary where we have this annotation:
(printf "#define START_XFORM_SKIP /**/~n")
(printf "#define END_XFORM_SKIP /**/~n")
(printf "#define START_XFORM_SUSPEND /**/~n")
(printf "#define END_XFORM_SUSPEND /**/~n")
(printf "#define XFORM_START_SKIP /**/~n")
(printf "#define XFORM_END_SKIP /**/~n")
(printf "#define XFORM_START_SUSPEND /**/~n")
(printf "#define XFORM_END_SUSPEND /**/~n")
;; For avoiding warnings:
(printf "#define XFORM_OK_PLUS +~n")
(printf "#define XFORM_OK_MINUS -~n")
(printf "#define XFORM_TRUST_PLUS +~n")
(printf "#define XFORM_TRUST_MINUS -~n")
(printf "~n")
;; C++ cupport:
@ -810,7 +817,8 @@
;; finding function calls
(define non-functions
'(<= < > >= == != !
\| \|\| & && |:| ? % + - * / ^ >> << ~ #csXFORM_OK_PLUS #csXFORM_OK_MINUS
\| \|\| & && |:| ? % + - * / ^ >> << ~
#csXFORM_OK_PLUS #csXFORM_OK_MINUS #csXFORM_TRUST_PLUS #csXFORM_TRUST_MINUS
= >>= <<= ^= += *= /= -= %= \|= &= ++ --
return sizeof if for while else switch case
asm __asm __asm__ __volatile __volatile__ volatile __extension__
@ -1194,7 +1202,8 @@
(newline/indent indent)
(display/indent v (tok-n v))
(display/indent v " ")]
[(and (eq? '|HIDE_FROM_XFORM| (tok-n v))
[(and (or (eq? '|HIDE_FROM_XFORM| (tok-n v))
(eq? '|XFORM_HIDE_EXPR| (tok-n v)))
(pair? (cdr e))
(seq? (cadr e))
(null? (seq->list (seq-in (cadr e)))))
@ -1465,23 +1474,28 @@
(define (end-skip? e)
(and (pair? e)
(eq? END_XFORM_SKIP (tok-n (car e)))))
(or (eq? END_XFORM_SKIP (tok-n (car e)))
(eq? 'XFORM_END_SKIP (tok-n (car e))))))
(define (start-suspend? e)
(and (pair? e)
(eq? START_XFORM_SUSPEND (tok-n (car e)))))
(or (eq? START_XFORM_SUSPEND (tok-n (car e)))
(eq? 'XFORM_START_SUSPEND (tok-n (car e))))))
(define (end-suspend? e)
(and (pair? e)
(eq? END_XFORM_SUSPEND (tok-n (car e)))))
(or (eq? END_XFORM_SUSPEND (tok-n (car e)))
(eq? 'XFORM_END_SUSPEND (tok-n (car e))))))
(define (start-arith? e)
(and (pair? e)
(eq? START_XFORM_ARITH (tok-n (car e)))))
(or (eq? START_XFORM_ARITH (tok-n (car e)))
(eq? 'XFORM_END_TRUST_ARITH (tok-n (car e))))))
(define (end-arith? e)
(and (pair? e)
(eq? END_XFORM_ARITH (tok-n (car e)))))
(or (eq? END_XFORM_ARITH (tok-n (car e)))
(eq? 'XFORM_START_TRUST_ARITH (tok-n (car e))))))
(define (access-modifier? e)
(and (memq (tok-n (car e)) '(public private protected))
@ -1719,7 +1733,8 @@
;; Parses a declaration of one line (which may have multiple, comma-separated variables).
;; Returns a list of pointer declarations and a list of non-pointer declarations.
(define (get-vars e comment union-ok?)
(let* ([e (if (eq? GC_CAN_IGNORE (tok-n (car e)))
(let* ([e (if (or (eq? GC_CAN_IGNORE (tok-n (car e)))
(eq? 'XFORM_CAN_IGNORE (tok-n (car e))))
(list (make-tok semi #f #f)) ; drop everything
(filter (lambda (x) (not (memq (tok-n x) '(volatile __volatile__ __volatile const)))) e))]
[base (tok-n (car e))]
@ -2863,7 +2878,7 @@
(parens? (car e-))
;; Something precedes
(not (null? (cdr e-)))
(eq? (tok-n (cadr e-)) '|HIDE_FROM_XFORM|)))
(memq (tok-n (cadr e-)) '(|HIDE_FROM_XFORM| |XFORM_HIDE_EXPR|))))
(define (cast-or-call e- cast-k call-k)
;; Looks like a function call, although we don't know the
@ -3033,7 +3048,9 @@
[(and (>= (length e) 3)
(let ([n (tok-n (car e))])
(or (number? n) (symbol? n)))
(memq (tok-n (cadr e)) '(+ - * / #csXFORM_OK_PLUS #csXFORM_OK_MINUS)))
(memq (tok-n (cadr e)) '(+ - * /
#csXFORM_OK_PLUS #csXFORM_OK_MINUS
#csXFORM_TRUST_PLUS #csXFORM_TRUST_MINUS)))
(let ([k (lift-in-arithmetic? (cddr e))])
(and k
(lambda (wrap)
@ -3047,7 +3064,9 @@
(and (>= len 3)
(let ([n (tok-n (list-ref e (sub1 len)))])
(or (number? n) (symbol? n)))
(memq (tok-n (list-ref e (- len 2))) '(+ - * / #csXFORM_OK_PLUS #csXFORM_OK_MINUS))))
(memq (tok-n (list-ref e (- len 2))) '(+ - * /
#csXFORM_OK_PLUS #csXFORM_OK_MINUS
#csXFORM_TRUST_PLUS #csXFORM_TRUST_MINUS))))
(let* ([last? (null? el)]
[len (if last?
(length e)

16
collects/mred/private/editor.ss
View File

@ -356,14 +356,14 @@
(unless (memq type '(text pasteboard))
(raise-type-error (who->name '(method editor<%> on-new-box)) "symbol: text or pasteboard" type))
(make-object editor-snip%
(let ([e (make-object (cond
[(eq? type 'pasteboard) pasteboard%]
[else text%]))])
(send e set-keymap (get-keymap))
(send e set-style-list (get-style-list))
(send e set-max-undo-history (get-max-undo-history))
e))))])
(let ([e (make-object (cond
[(eq? type 'pasteboard) pasteboard%]
[else text%]))])
(send e set-keymap (get-keymap))
(send e set-style-list (get-style-list))
(send e set-max-undo-history (get-max-undo-history))
e))))])
(apply super-make-object args)))
(define text%

2
collects/mred/private/kernel.ss
View File

@ -1336,6 +1336,8 @@
set-inset
get-margin
set-margin
style-background-used?
use-style-background
border-visible?
show-border
set-align-top-line

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

@ -59,6 +59,7 @@
(err/rt-test (make-struct-field-accessor sel 3) exn:application:mismatch?)
(let ([an-a (make 'one 'two)]
[an-ax (makex)])
(test #f procedure-struct-type? type)
(test #f procedure? an-a)
(test #f procedure? an-ax)
@ -198,6 +199,7 @@
;; Derived, adds proc
[(type3 make3 pred3 sel3 set3) (make-struct-type 'r struct:arity-at-least 1 1 (lambda (x) (pred3 x))
null t-insp proc)])
(test #t procedure-struct-type? type)
(let* ([bad1 (make 17)]
[bad2 (make2 18 -18)]
[bad3 (make3 #f 19)]

2
collects/wxme/wxme.ss
View File

@ -406,6 +406,8 @@
(read-integer who port vers "nested-editor tight-fit?"))
(when (cvers . > . 2)
(read-integer who port vers "nested-editor alignment"))
(when (cvers . > . 3)
(read-integer who port vers "use background color"))
(let ([n (read-editor-snip who port vers header)])
(if (header-plain-text? header)
n

5
doc/release-notes/mred/HISTORY
View File

@ -1,3 +1,8 @@
Version 369.9
Added use-background-style and background-style-used? methods
to editor-snip%; changes the editor-snip WXME format
Version 369.6
WXME file format changed to include a #reader() prefix

6
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,9 @@
Version 369.9
Module top-level enforces initial categorization of expressions
versus other forms
Added procedure-struct-type?
Inside MzScheme: XFORM_START_SKIP, etc.
Version 369.8
Added -p, -P, and -Q command-line options
Changed H-expression parsing to represent angle brackets specially

5
src/mred/Makefile.in
View File

@ -103,8 +103,9 @@ bin:
3m:
$(MAKE) ext-libs
$(MAKE) @WXVARIANT@-min
cd gc2; make gen-deps
cd gc2; make 3m
cd wxs; $(MAKE) ccsources
cd gc2; $(MAKE) gen-deps
cd gc2; $(MAKE) 3m
cgc:
$(MAKE) ext-libs

9
src/mred/wxme/wx_mpbrd.cxx
View File

@ -1716,9 +1716,8 @@ void wxMediaPasteboard::Refresh(double localx, double localy, double w, double h
wxBrush *brush;
wxFont *font;
wxColour *fg, *bg;
#ifndef NO_GET_CLIPPING_REGION
int bgmode;
wxRegion *rgn;
#endif
pen = dc->GetPen();
brush = dc->GetBrush();
@ -1730,23 +1729,21 @@ void wxMediaPasteboard::Refresh(double localx, double localy, double w, double h
clr = dc->GetTextBackground();
bg = new WXGC_PTRS wxColour(clr);
}
bgmode = dc->GetBackgroundMode();
#ifndef NO_GET_CLIPPING_REGION
rgn = dc->GetClippingRegion();
dc->SetClippingRect(localx - dx, localy - dy, w, h);
#endif
Draw(dc, -dx, -dy, localx, localy, w, h, show_caret, bgColor);
#ifndef NO_GET_CLIPPING_REGION
dc->SetClippingRegion(rgn);
#endif
dc->SetBrush(brush);
dc->SetPen(pen);
dc->SetFont(font);
dc->SetTextForeground(fg);
dc->SetTextBackground(bg);
dc->SetBackgroundMode(bgmode);
}
EndSequenceLock();

7
src/mred/wxme/wx_mpriv.cxx
View File

@ -2647,9 +2647,8 @@ void wxMediaEdit::Refresh(double left, double top, double width, double height,
wxBrush *brush;
wxFont *font;
wxColour *fg, *bg, *col;
#ifndef NO_GET_CLIPPING_REGION
wxRegion *rgn;
#endif
int bgmode;
pen = dc->GetPen();
brush = dc->GetBrush();
@ -2658,7 +2657,8 @@ void wxMediaEdit::Refresh(double left, double top, double width, double height,
fg = new WXGC_PTRS wxColour(col);
col = dc->GetTextBackground();
bg = new WXGC_PTRS wxColour(col);
bgmode = dc->GetBackgroundMode();
rgn = dc->GetClippingRegion();
dc->SetClippingRect(left - x, top - y, width, height);
@ -2671,6 +2671,7 @@ void wxMediaEdit::Refresh(double left, double top, double width, double height,
dc->SetFont(font);
dc->SetTextForeground(fg);
dc->SetTextBackground(bg);
dc->SetBackgroundMode(bgmode);
}
EndSequenceLock();

77
src/mred/wxme/wx_msnip.cxx
View File

@ -425,6 +425,36 @@ void wxMediaSnip::Draw(wxDC *dc, double x, double y,
r = ((r < right) ? r : right);
b = ((b < bottom) ? b : bottom);
if (useStyleBG) {
if (style->GetTransparentTextBacking()) {
bgColor = NULL;
} else {
wxBrush *saveb, *fill;
wxPen *savep, *transPen;
bgColor = style->GetBackground();
l = orig_x + leftInset;
t = orig_y + topInset;
r = l + (w + leftMargin + rightMargin - (leftInset + rightInset)) - 1;
b = t + (h + topMargin + bottomMargin - (topInset + bottomInset)) - 1;
transPen = wxThePenList->FindOrCreatePen(bgColor, 0, wxTRANSPARENT);
fill = wxTheBrushList->FindOrCreateBrush(bgColor, wxSOLID);
savep = dc->GetPen();
saveb = dc->GetBrush();
dc->SetPen(transPen);
dc->SetBrush(fill);
dc->DrawRectangle(l, t, r - l, b - t);
dc->SetBrush(saveb);
dc->SetPen(savep);
}
}
if (me)
me->Refresh(l - x, t - y, r - l, b - t, show_caret, bgColor);
@ -484,7 +514,7 @@ wxSnip *wxMediaSnip::Copy(void)
void wxMediaSnip::Write(wxMediaStreamOut *f)
{
Bool wb = withBorder, tf = tightFit, ta = alignTopLine;
Bool wb = withBorder, tf = tightFit, ta = alignTopLine, usbg = useStyleBG;
f->Put((me ? me->bufferType : 0));
f->Put(wb);
@ -502,6 +532,7 @@ void wxMediaSnip::Write(wxMediaStreamOut *f)
f->Put(maxHeight);
f->Put(tf);
f->Put(ta);
f->Put(usbg);
if (me)
me->WriteToFile(f);
@ -564,6 +595,19 @@ void wxMediaSnip::SetAlignTopLine(Bool t)
admin->Resized(this, TRUE);
}
void wxMediaSnip::UseStyleBG(Bool useit)
{
if ((useStyleBG ? 1 : 0) != (useit ? 1 : 0)) {
useStyleBG = (useit ? TRUE : FALSE);
RequestRefresh();
}
}
Bool wxMediaSnip::StyleBGUsed()
{
return useStyleBG;
}
Bool wxMediaSnip::Resize(double w, double h)
{
w -= leftMargin + rightMargin;
@ -586,23 +630,28 @@ Bool wxMediaSnip::Resize(double w, double h)
return TRUE;
}
void wxMediaSnip::RequestRefresh()
{
if (admin) {
wxDC *dc;
double w, h;
dc = admin->GetDC();
if (dc) {
w = h = 0.0;
GetExtent(dc, 0, 0, &w, &h);
admin->NeedsUpdate(this, leftInset, topInset,
w + rightMargin - rightInset,
h + bottomMargin - bottomInset);
}
}
}
void wxMediaSnip::ShowBorder(Bool show)
{
if ((withBorder ? 1 : 0) != (show ? 1 : 0)) {
withBorder = (show ? TRUE : FALSE);
if (admin) {
wxDC *dc;
double w, h;
dc = admin->GetDC();
if (dc) {
w = h = 0.0;
GetExtent(dc, 0, 0, &w, &h);
admin->NeedsUpdate(this, leftInset, topInset,
w + rightMargin - rightInset,
h + bottomMargin - bottomInset);
}
}
RequestRefresh();
}
}

8
src/mred/wxme/wx_snip.cxx
View File

@ -1704,7 +1704,7 @@ static MediaSnipClass *TheMediaSnipClass;
MediaSnipClass::MediaSnipClass(void)
{
classname = "wxmedia";
version = 3;
version = 4;
required = TRUE;
}
@ -1712,7 +1712,7 @@ wxSnip *MediaSnipClass::Read(wxMediaStreamIn *f)
{
wxMediaBuffer *media;
wxMediaSnip *snip;
Bool border, tightFit = 0, alignTopLine = 0;
Bool border, tightFit = 0, alignTopLine = 0, useStyleBG = 0;
int lm, tm, rm, bm, li, ti, ri, bi, type;
double w, W, h, H;
wxStandardSnipClassList *scl;
@ -1737,6 +1737,8 @@ wxSnip *MediaSnipClass::Read(wxMediaStreamIn *f)
f->Get(&tightFit);
if (f->ReadingVersion(this) > 2)
f->Get(&alignTopLine);
if (f->ReadingVersion(this) > 3)
f->Get(&useStyleBG);
if (!type)
media = NULL;
@ -1760,6 +1762,8 @@ wxSnip *MediaSnipClass::Read(wxMediaStreamIn *f)
snip->SetTightTextFit(1);
if (alignTopLine)
snip->SetAlignTopLine(1);
if (useStyleBG)
snip->UseStyleBG(1);
if (media) {
wxStyleList *sl;

5
src/mred/wxme/wx_snip.h
View File

@ -375,6 +375,7 @@ class wxMediaSnip : public wxInternalSnip
TF_Flag( withBorder );
TF_Flag( tightFit );
TF_Flag( alignTopLine );
TF_Flag( useStyleBG );
#undef TF_Flag
int leftMargin, topMargin, rightMargin, bottomMargin;
@ -447,6 +448,8 @@ class wxMediaSnip : public wxInternalSnip
void ShowBorder(Bool show);
Bool BorderVisible();
void UseStyleBG(Bool useit);
Bool StyleBGUsed();
void SetMargin(int lm, int tm, int rm, int bm);
void GetMargin(int *lm, int *tm, int *rm, int *bm);
@ -459,6 +462,8 @@ class wxMediaSnip : public wxInternalSnip
wxMediaBuffer *GetThisMedia(void);
void SetMedia(wxMediaBuffer *b);
void RequestRefresh();
};
/**********************************************************************/

48
src/mred/wxs/wxs_snip.cxx
View File

@ -8820,6 +8820,7 @@ class wxImageSnip *objscheme_unbundle_wxImageSnip(Scheme_Object *obj, const char
class os_wxMediaSnip : public wxMediaSnip {
@ -9984,6 +9985,49 @@ static Scheme_Object *os_wxMediaSnipSetMargin(int n, Scheme_Object *p[])
READY_TO_RETURN;
return scheme_void;
}
static Scheme_Object *os_wxMediaSnipStyleBGUsed(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
Bool r;
objscheme_check_valid(os_wxMediaSnip_class, "style-background-used? in editor-snip%", n, p);
SETUP_VAR_STACK_REMEMBERED(1);
VAR_STACK_PUSH(0, p);
r = WITH_VAR_STACK(((wxMediaSnip *)((Scheme_Class_Object *)p[0])->primdata)->StyleBGUsed());
READY_TO_RETURN;
return (r ? scheme_true : scheme_false);
}
static Scheme_Object *os_wxMediaSnipUseStyleBG(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
objscheme_check_valid(os_wxMediaSnip_class, "use-style-background in editor-snip%", n, p);
Bool x0;
SETUP_VAR_STACK_REMEMBERED(1);
VAR_STACK_PUSH(0, p);
x0 = WITH_VAR_STACK(objscheme_unbundle_bool(p[POFFSET+0], "use-style-background in editor-snip%"));
WITH_VAR_STACK(((wxMediaSnip *)((Scheme_Class_Object *)p[0])->primdata)->UseStyleBG(x0));
READY_TO_RETURN;
return scheme_void;
}
@ -11230,12 +11274,14 @@ void objscheme_setup_wxMediaSnip(Scheme_Env *env)
wxREGGLOB(os_wxMediaSnip_class);
os_wxMediaSnip_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "editor-snip%", "snip%", (Scheme_Method_Prim *)os_wxMediaSnip_ConstructScheme, 44));
os_wxMediaSnip_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "editor-snip%", "snip%", (Scheme_Method_Prim *)os_wxMediaSnip_ConstructScheme, 46));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "get-inset" " method", (Scheme_Method_Prim *)os_wxMediaSnipGetInset, 4, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "set-inset" " method", (Scheme_Method_Prim *)os_wxMediaSnipSetInset, 4, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "get-margin" " method", (Scheme_Method_Prim *)os_wxMediaSnipGetMargin, 4, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "set-margin" " method", (Scheme_Method_Prim *)os_wxMediaSnipSetMargin, 4, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "style-background-used?" " method", (Scheme_Method_Prim *)os_wxMediaSnipStyleBGUsed, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "use-style-background" " method", (Scheme_Method_Prim *)os_wxMediaSnipUseStyleBG, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "border-visible?" " method", (Scheme_Method_Prim *)os_wxMediaSnipBorderVisible, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "show-border" " method", (Scheme_Method_Prim *)os_wxMediaSnipShowBorder, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaSnip_class, "set-align-top-line" " method", (Scheme_Method_Prim *)os_wxMediaSnipSetAlignTopLine, 1, 1));

3
src/mred/wxs/wxs_snip.xc
View File

@ -142,6 +142,9 @@
@ "show-border" : void ShowBorder(bool);
@ "border-visible?" : bool BorderVisible();
@ "use-style-background" : void UseStyleBG(bool);
@ "style-background-used?" : bool StyleBGUsed();
@ "set-margin" : void SetMargin(nnint,nnint,nnint,nnint);
@ "get-margin" :void GetMargin(nnint*,nnint*,nnint*,nnint*);
@ "set-inset" :void SetInset(nnint,nnint,nnint,nnint);

10
src/mzscheme/include/scheme.h
View File

@ -1577,6 +1577,16 @@ extern void *scheme_malloc_envunbox(size_t);
# define MZ_GC_NO_VAR_IN_REG(x) /* empty */
# define MZ_GC_REG() /* empty */
# define MZ_GC_UNREG() /* empty */
# define XFORM_HIDE_EXPR(x) x
# define XFORM_START_SKIP /**/
# define XFORM_END_SKIP /**/
# define XFORM_START_SUSPEND /**/
# define XFORM_END_SUSPEND /**/
# define XFORM_START_TRUST_ARITH /**/
# define XFORM_END_TRUST_ARITH /**/
# define XFORM_CAN_IGNORE /**/
# define XFORM_TRUST_PLUS +
# define XFORM_TRUST_MINUS -
#endif
/*========================================================================*/

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

File diff suppressed because it is too large Load Diff

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

@ -4092,7 +4092,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
and provides. Also, flatten top-level `begin' expressions: */
for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) {
Scheme_Object *e;
int normal;
int kind;
while (1) {
Scheme_Object *fst;
@ -4226,7 +4226,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
}
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 1;
kind = 2;
} else if (scheme_stx_module_eq(scheme_define_syntaxes_stx, fst, 0)
|| scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0)) {
/************ define-syntaxes & define-values-for-syntax *************/
@ -4364,7 +4364,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
}
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
kind = 0;
} else if (scheme_stx_module_eq(require_stx, fst, 0)) {
/************ require *************/
Scheme_Object *imods;
@ -4385,7 +4385,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
kind = 0;
} else if (scheme_stx_module_eq(require_for_syntax_stx, fst, 0)) {
/************ require-for-syntax *************/
Scheme_Object *imods;
@ -4412,7 +4412,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
kind = 0;
} else if (scheme_stx_module_eq(require_for_template_stx, fst, 0)) {
/************ require-for-template *************/
Scheme_Object *imods;
@ -4439,7 +4439,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
kind = 0;
} else if (scheme_stx_module_eq(provide_stx, fst, 0)) {
/************ provide *************/
/* Add provides to table: */
@ -4699,17 +4699,17 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
kind = 0;
} else {
normal = 1;
kind = 1;
}
} else
normal = 1;
kind = 1;
} else
normal = 1;
kind = 1;
if (e) {
p = scheme_make_pair(scheme_make_pair(e, normal ? scheme_true : scheme_false), scheme_null);
p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(kind)), scheme_null);
if (last)
SCHEME_CDR(last) = p;
else
@ -4727,7 +4727,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
maybe_has_lifts = 0;
}
}
/* first = a list of (cons semi-expanded-expression normal?) */
/* first = a list of (cons semi-expanded-expression kind) */
/* Pass 2 */
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
@ -4749,31 +4749,38 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
prev_p = NULL;
for (p = first; !SCHEME_NULLP(p); ) {
Scheme_Object *e, *l, *ll;
int normal;
int kind;
e = SCHEME_CAR(p);
normal = SCHEME_TRUEP(SCHEME_CDR(e));
kind = SCHEME_INT_VAL(SCHEME_CDR(e));
e = SCHEME_CAR(e);
SCHEME_EXPAND_OBSERVE_NEXT(observer);
if (normal) {
if (kind) {
Scheme_Comp_Env *nenv;
l = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(cenv)
: scheme_null);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l);
maybe_has_lifts = 1;
if (kind == 2)
nenv = cenv;
else
nenv = scheme_new_compilation_frame(0, 0, cenv, NULL);
if (rec[drec].comp) {
Scheme_Compile_Info crec1;
scheme_init_compile_recs(rec, drec, &crec1, 1);
crec1.resolve_module_ids = 0;
e = scheme_compile_expr(e, cenv, &crec1, 0);
e = scheme_compile_expr(e, nenv, &crec1, 0);
} else {
Scheme_Expand_Info erec1;
scheme_init_expand_recs(rec, drec, &erec1, 1);
erec1.value_name = scheme_false;
e = scheme_expand_expr(e, cenv, &erec1, 0);
e = scheme_expand_expr(e, nenv, &erec1, 0);
}
l = scheme_frame_get_lifts(cenv);
@ -4785,10 +4792,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
} else {
/* Lifts - insert them and try again */
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
e = scheme_make_pair(e, scheme_false); /* don't re-compile/-expand */
e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */
SCHEME_CAR(p) = e;
for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
e = scheme_make_pair(SCHEME_CAR(ll), scheme_true);
e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(2));
SCHEME_CAR(ll) = e;
}
p = scheme_append(l, p);
@ -4810,7 +4817,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, scheme_reverse(p));
p = scheme_reverse(p);
for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
e = scheme_make_pair(SCHEME_CAR(ll), scheme_true);
e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(1));
SCHEME_CAR(ll) = e;
}
maybe_has_lifts = 0;

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 891
#define EXPECTED_PRIM_COUNT 892
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 369
#define MZSCHEME_VERSION_MINOR 8
#define MZSCHEME_VERSION_MINOR 9
#define MZSCHEME_VERSION "369.8" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "369.9" _MZ_SPECIAL_TAG

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

@ -76,6 +76,7 @@ static Scheme_Object *handle_evt_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_type_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *proc_struct_type_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_info(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[]);
@ -386,6 +387,12 @@ scheme_init_struct (Scheme_Env *env)
"struct-type-property?",
1, 1, 1),
env);
scheme_add_global_constant("procedure-struct-type?",
scheme_make_folding_prim(proc_struct_type_p,
"procedure-struct-type?",
1, 1, 1),
env);
/*** Debugging ****/
@ -1337,6 +1344,18 @@ struct_type_p(int argc, Scheme_Object *argv[])
? scheme_true : scheme_false);
}
static Scheme_Object *proc_struct_type_p(int argc, Scheme_Object *argv[])
{
if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_struct_type_type)) {
if (((Scheme_Struct_Type *)argv[0])->proc_attr)
return scheme_true;
else
return scheme_false;
}
scheme_wrong_type("procedure-struct-type?", "struct-type", 0, argc, argv);
return NULL;
}
static Scheme_Object *struct_info(int argc, Scheme_Object *argv[])
{
Scheme_Structure *s;