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

369.5

Browse Source 
svn: r5366
This commit is contained in:
Matthew Flatt 2007-01-16 20:55:13 +00:00
parent e51405b682
commit 87c0d5754e
41 changed files with 2039 additions and 1714 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/eopl/datatype.ss
View File

@ -81,7 +81,7 @@
;; Also, this isn't a transformer function, so any direct
;; use of the name will trigger a syntax error. The name
;; can be found by `syntax-local-value', though.
(let ([cert (syntax-local-certifier)])
(let ([cert (syntax-local-certifier #t)])
(make-dt (cert (syntax pred-name))
(list
(make-vt (cert (syntax variant-name))

21
collects/frtime/frp-core.ss
View File

@ -85,24 +85,25 @@
(define-syntax signal
(let ([field-name-symbols (list 'value 'dependents 'stale? 'thunk
'depth 'continuation-marks 'parameterization
'producers)])
'producers)]
[cert (syntax-local-certifier #t)])
(list-immutable
((syntax-local-certifier) #'struct:signal)
((syntax-local-certifier) #'make-signal)
((syntax-local-certifier) #'signal?)
(cert #'struct:signal)
(cert #'make-signal)
(cert #'signal?)
(apply list-immutable
(map
(lambda (fd)
((syntax-local-certifier) (datum->syntax-object
#'here
(string->symbol (format "signal-~a" fd)))))
(cert (datum->syntax-object
#'here
(string->symbol (format "signal-~a" fd)))))
(reverse field-name-symbols)))
(apply list-immutable
(map
(lambda (fd)
((syntax-local-certifier) (datum->syntax-object
#'here
(string->symbol (format "set-signal-~a!" fd)))))
(cert (datum->syntax-object
#'here
(string->symbol (format "set-signal-~a!" fd)))))
(reverse field-name-symbols)))
#t)))

101
collects/frtime/struct.ss
View File

@ -98,29 +98,30 @@
[else (loop (cdr l))]))
(append base '(#f)))
base))]
[cert-f (gensym)]
[qs (lambda (x) (if (eq? x #t)
x
(and x `((syntax-local-certifier) (quote-syntax ,x)))))])
`(list-immutable
,(qs (car names))
,(qs (cadr names))
,(qs (caddr names))
(list-immutable
,@(reverse (if omit-sel?
null
(map qs (if omit-set? flds (every-other flds)))))
,@(map qs (add-#f omit-sel? base-getters)))
(list-immutable
,@(reverse (if omit-set?
null
(map qs (if omit-sel?
flds
(every-other (if (null? flds)
null
(cdr flds)))))))
,@(map qs (add-#f omit-set? base-setters)))
,(qs base-name)))))
(and x `(,cert-f (quote-syntax ,x)))))])
`(let ([,cert-f (syntax-local-certifier #t)])
(list-immutable
,(qs (car names))
,(qs (cadr names))
,(qs (caddr names))
(list-immutable
,@(reverse (if omit-sel?
null
(map qs (if omit-set? flds (every-other flds)))))
,@(map qs (add-#f omit-sel? base-getters)))
(list-immutable
,@(reverse (if omit-set?
null
(map qs (if omit-sel?
flds
(every-other (if (null? flds)
null
(cdr flds)))))))
,@(map qs (add-#f omit-set? base-setters)))
,(qs base-name))))))
(define (struct-declaration-info? x)
(define (identifier/#f? x)
@ -158,15 +159,16 @@
;; if `defined-names' is #f.
;; If `expr?' is #t, then generate an expression to build the info,
;; otherwise build the info directly.
(let ([qs (if gen-expr? (lambda (x) #`((syntax-local-certifier) (quote-syntax #,x))) values)]
[every-other (lambda (l)
(let loop ([l l][r null])
(cond
[(null? l) r]
[(null? (cdr l)) (cons (car l) r)]
[else (loop (cddr l) (cons (car l) r))])))]
[super-info (and super-id
(syntax-local-value super-id (lambda () #f)))])
(let* ([cert-f (gensym)]
[qs (if gen-expr? (lambda (x) #`(#,cert-f (quote-syntax #,x))) values)]
[every-other (lambda (l)
(let loop ([l l][r null])
(cond
[(null? l) r]
[(null? (cdr l)) (cons (car l) r)]
[else (loop (cddr l) (cons (car l) r))])))]
[super-info (and super-id
(syntax-local-value super-id (lambda () #f)))])
(when super-id
;; Did we get valid super-info ?
(when (or (not (struct-declaration-info? super-info))
@ -193,25 +195,26 @@
(values null null))]
[(fields) (cdddr defined-names)]
[(wrap) (if gen-expr? (lambda (x) #`(list-immutable #,@x)) values)])
(wrap
(list-immutable (qs (car defined-names))
(qs (cadr defined-names))
(qs (caddr defined-names))
(wrap
(apply
list-immutable
(append (map qs (every-other fields))
initial-gets)))
(wrap
(apply
list-immutable
(append (map qs (if (null? fields)
null
(every-other (cdr fields))))
initial-sets)))
(if super-id
(qs super-id)
#t))))
#`(let ([#,cert-f (syntax-local-certifier #t)])
#,(wrap
(list-immutable (qs (car defined-names))
(qs (cadr defined-names))
(qs (caddr defined-names))
(wrap
(apply
list-immutable
(append (map qs (every-other fields))
initial-gets)))
(wrap
(apply
list-immutable
(append (map qs (if (null? fields)
null
(every-other (cdr fields))))
initial-sets)))
(if super-id
(qs super-id)
#t)))))
#f))))
(define (make-core make-make-struct-type orig-stx defined-names super-info name field-names)

4
collects/lang/prim.ss
View File

@ -48,7 +48,7 @@
"this primitive operator must be applied to arguments; "
"expected an open parenthesis before the operator name")
stx)])))
((syntax-local-certifier)
((syntax-local-certifier #t)
#'impl))))]))
(define-syntax (define-higher-order-primitive stx)
@ -126,7 +126,7 @@
"this primitive operator must be applied to arguments; "
"expected an open parenthesis before the operator name")
s)])))
((syntax-local-certifier)
((syntax-local-certifier #t)
#'impl))))))))]))
(define-syntax (fo->ho stx)

9
collects/mred/edit.ss
View File

@ -68,6 +68,15 @@
(lambda (item event)
(send e save-file "" 'text))))
(make-object separator-menu-item% file-menu)
(when (can-get-page-setup-from-user?)
(make-object menu-item% "Page Setup..." file-menu
(lambda (item event)
(let ([s (get-page-setup-from-user #f f)])
(when s
(send (current-ps-setup) copy-from s))))
#\P
#f void
(cons 'shift (get-default-shortcut-prefix))))
(make-object menu-item% "Print..." file-menu
(lambda (item event)
(send e print))

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

@ -181,7 +181,7 @@
(let ([s (make-object wx:ps-setup%)])
(send s copy-from (or pss-in (wx:current-ps-setup)))
(and (parameterize ([wx:current-ps-setup s])
(wx:show-print-setup parent))
(wx:show-print-setup (and parent (mred->wx parent))))
s)))]))
(define (can-get-page-setup-from-user?)

19
collects/mzlib/private/contract.ss
View File

@ -434,18 +434,19 @@ add struct contracts for immutable structs?
[super-id (if (boolean? super-id)
super-id
(with-syntax ([super-id super-id])
(syntax ((syntax-local-certifier) #'super-id))))])
(syntax (cert #'super-id))))])
(syntax (begin
(provide (rename id-rename struct-name))
(define-syntax id-rename
(list-immutable ((syntax-local-certifier) #'-struct:struct-name)
((syntax-local-certifier) #'constructor-new-name)
((syntax-local-certifier) #'predicate-new-name)
(list-immutable ((syntax-local-certifier) #'rev-selector-new-names) ...
((syntax-local-certifier) #'rev-selector-old-names) ...)
(list-immutable ((syntax-local-certifier) #'rev-mutator-new-names) ...
((syntax-local-certifier) #'rev-mutator-old-names) ...)
super-id)))))]
(let ([cert (syntax-local-certifier #t)])
(list-immutable (cert #'-struct:struct-name)
(cert #'constructor-new-name)
(cert #'predicate-new-name)
(list-immutable (cert #'rev-selector-new-names) ...
(cert #'rev-selector-old-names) ...)
(list-immutable (cert #'rev-mutator-new-names) ...
(cert #'rev-mutator-old-names) ...)
super-id))))))]
[struct:struct-name struct:struct-name]
[-struct:struct-name -struct:struct-name]
[struct-name struct-name]

100
collects/syntax/struct.ss
View File

@ -176,28 +176,30 @@
(append base '(#f))
base)
base))]
[cert-f (gensym)]
[qs (lambda (x) (if (eq? x #t)
x
(and x `((syntax-local-certifier) (quote-syntax ,x)))))])
`(list-immutable
,(qs (car names))
,(qs (cadr names))
,(qs (caddr names))
(list-immutable
,@(reverse (if omit-sel?
null
(map qs (if omit-set? flds (every-other flds)))))
,@(map qs (add-#f omit-sel? base-getters)))
(list-immutable
,@(reverse (if omit-set?
null
(map qs (if omit-sel?
flds
(every-other (if (null? flds)
null
(cdr flds)))))))
,@(map qs (add-#f omit-set? base-setters)))
,(qs base-name)))))
(and x `(,cert-f (quote-syntax ,x)))))])
`(let ([,cert-f (syntax-local-certifier #t)])
(list-immutable
,(qs (car names))
,(qs (cadr names))
,(qs (caddr names))
(list-immutable
,@(reverse (if omit-sel?
null
(map qs (if omit-set? flds (every-other flds)))))
,@(map qs (add-#f omit-sel? base-getters)))
(list-immutable
,@(reverse (if omit-set?
null
(map qs (if omit-sel?
flds
(every-other (if (null? flds)
null
(cdr flds)))))))
,@(map qs (add-#f omit-set? base-setters)))
,(qs base-name))))))
(define (struct-declaration-info? x)
@ -236,15 +238,16 @@
;; if `defined-names' is #f.
;; If `expr?' is #t, then generate an expression to build the info,
;; otherwise build the info directly.
(let ([qs (lambda (x) #`((syntax-local-certifier) (quote-syntax #,x)))]
[every-other (lambda (l)
(let loop ([l l][r null])
(cond
[(null? l) r]
[(null? (cdr l)) (cons (car l) r)]
[else (loop (cddr l) (cons (car l) r))])))]
[super-info (and super-id
(syntax-local-value super-id (lambda () #f)))])
(let* ([cert-f (gensym)]
[qs (lambda (x) #`(#,cert-f (quote-syntax #,x)))]
[every-other (lambda (l)
(let loop ([l l][r null])
(cond
[(null? l) r]
[(null? (cdr l)) (cons (car l) r)]
[else (loop (cddr l) (cons (car l) r))])))]
[super-info (and super-id
(syntax-local-value super-id (lambda () #f)))])
(when super-id
;; Did we get valid super-info ?
(when (or (not (struct-declaration-info? super-info))
@ -271,25 +274,26 @@
(values null null))]
[(fields) (cdddr defined-names)]
[(wrap) (lambda (x) #`(list-immutable #,@x))])
(wrap
(list-immutable (qs (car defined-names))
(qs (cadr defined-names))
(qs (caddr defined-names))
(wrap
(apply
list-immutable
(append (map qs (every-other fields))
initial-gets)))
(wrap
(apply
list-immutable
(append (map qs (if (null? fields)
null
(every-other (cdr fields))))
initial-sets)))
(if super-id
(qs super-id)
#t))))
#`(let ([#,cert-f (syntax-local-certifier)])
#,(wrap
(list-immutable (qs (car defined-names))
(qs (cadr defined-names))
(qs (caddr defined-names))
(wrap
(apply
list-immutable
(append (map qs (every-other fields))
initial-gets)))
(wrap
(apply
list-immutable
(append (map qs (if (null? fields)
null
(every-other (cdr fields))))
initial-sets)))
(if super-id
(qs super-id)
#t)))))
#f))))
(define (make-core make-make-struct-type orig-stx defined-names super-info name field-names)

19
collects/tests/mzscheme/file.ss
View File

@ -173,6 +173,25 @@
(test #\l read-char s)
(test 3 file-position s))
(let ([os (open-output-string)])
(write '((0 54609) (1 32874234)) os)
(file-position os 2)
(file-position os eof)
(test #"((0 54609) (1 32874234))" get-output-bytes os))
(let ([os (open-output-string)])
(write '1234 os)
(file-position os 10)
(write 'z os)
(test #"1234\0\0\0\0\0\0z" get-output-bytes os))
(let ([os (open-output-string)])
(write '1234 os)
(file-position os 10)
(file-position os eof)
(write 'z os)
(test #"1234\0\0\0\0\0\0z" get-output-bytes os))
(define s (open-output-string))
(err/rt-test (file-position 's 1))
(err/rt-test (file-position s 'one))

29
collects/tests/mzscheme/prompt-tests.ss
View File

@ -1,4 +1,33 @@
(let ([try
(lambda (thread m-top n-top do-mid-stream do-abort)
(let ([result #f])
(thread-wait
(thread
(lambda ()
(set! result
(let pre-loop ([m m-top])
(if (zero? m)
(list
(do-mid-stream
(lambda ()
(call-with-continuation-prompt
(lambda ()
(let loop ([n n-top])
(if (zero? n)
(do-abort
(lambda ()
(abort-current-continuation
(default-continuation-prompt-tag)
(lambda () 5000))))
(+ (loop (sub1 n))))))))))
(list (car (pre-loop (sub1 m))))))))))
(test '(5000) values result)))])
(try thread 5000 10000 (lambda (mid) (mid))
(lambda (abort) (((call/cc
(lambda (k) (lambda () k))))
(lambda () (lambda (x) 5000))))))
(test-breaks-ok)
;;----------------------------------------

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

@ -1,3 +1,9 @@
Version 369.5
Mac OS X printer-dc% uses scaling specified by the current ps-setup%
----------------------------------------------------------------------
Version 360, November 2006
Added get-other-altgr-key-code and get-other-shift-altgr-key-code

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

@ -1,3 +1,11 @@
Version 369.5
print-struct defaults to #t instead of #f
Changed make-exn to automatically convert a mutable message string
to an immutable string
Added initial custodian argument to custodian-require-memory
Added an argument to syntax-local-certifier indicating whether the
generated procedure attaches active or inactive certificates
Version 369.4
Default build uses 3m instead of CGC
Added 'gc and 'so-suffix flags for system-type
@ -6,6 +14,7 @@ Changed path->directory-path, simplify-path, and split-path to include
path without it
Changed simplify-path for Windows paths to replace / with \
Changed current-directory to apply path->directory-path to given paths
Added port-closed?
Version 369.3
Adjusted exception-handler calling to propagate any returned value

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

@ -121,7 +121,7 @@ XFORMDEP_NOPRECOMP = $(srcdir)/gc2.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss
XFORMDEP = $(XFORMDEP_NOPRECOMP) $(XSRCDIR)/precomp.h
$(XSRCDIR)/precomp.h : $(XFORMDEP_NOPRECOMP) $(srcdir)/precomp.c $(srcdir)/../src/schpriv.h $(srcdir)/../include/scheme.h \
$(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schvers.h
$(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schvers.h $(srcdir)/../src/schemef.h
env XFORM_PRECOMP=yes $(XFORM_NOPRECOMP) $(XSRCDIR)/precomp.h $(srcdir)/precomp.c
$(XSRCDIR)/salloc.c: ../src/salloc.@LTO@ $(XFORMDEP)

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

@ -385,12 +385,28 @@ static size_t round_to_apage_size(size_t sizeb)
return sizeb;
}
static unsigned long custodian_single_time_limit(int set);
inline static int thread_get_owner(void *p);
/* the core allocation functions */
static void *allocate_big(size_t sizeb, int type)
{
unsigned long sizew;
struct mpage *bpage;
if(GC_out_of_memory) {
/* We're allowed to fail. Check for allocations that exceed a single-time
limit. Otherwise, the limit doesn't work as intended, because
a program can allocate a large block that nearly exhausts memory,
and then a subsequent allocation can fail. As long as the limit
is much smaller than the actual available memory, and as long as
GC_out_of_memory protects any user-requested allocation whose size
is independent of any existing object, then we can enforce the limit. */
if (custodian_single_time_limit(thread_get_owner(scheme_current_thread)) < sizeb) {
GC_out_of_memory();
}
}
/* the actual size of this is the size, ceilinged to the next largest word,
plus the size of the page header, plus one word for the object header.
This last serves many purposes, including making sure the object is
@ -407,7 +423,11 @@ static void *allocate_big(size_t sizeb, int type)
/* We not only need APAGE_SIZE alignment, we
need everything consisently mapped within an APAGE_SIZE
segment. So round up. */
bpage = malloc_pages(round_to_apage_size(sizeb), APAGE_SIZE);
if (type == PAGE_ATOMIC) {
bpage = malloc_dirty_pages(round_to_apage_size(sizeb), APAGE_SIZE);
memset(bpage, 0, sizeof(struct mpage));
} else
bpage = malloc_pages(round_to_apage_size(sizeb), APAGE_SIZE);
bpage->size = sizeb;
bpage->big_page = 1;
bpage->page_type = type;
@ -1191,6 +1211,7 @@ inline static void register_new_thread(void *t, void *c)
work = (struct thread *)malloc(sizeof(struct thread));
work->owner = current_owner((Scheme_Custodian *)c);
((Scheme_Thread *)t)->gc_owner_set = work->owner;
work->thread = t;
work->next = threads;
threads = work;
@ -1202,6 +1223,7 @@ inline static void register_thread(void *t, void *c)
for(work = threads; work; work = work->next)
if(work->thread == t) {
work->owner = current_owner((Scheme_Custodian *)c);
((Scheme_Thread *)t)->gc_owner_set = work->owner;
return;
}
register_new_thread(t, c);
@ -1212,8 +1234,12 @@ inline static void mark_threads(int owner)
struct thread *work;
for(work = threads; work; work = work->next)
if(work->owner == owner)
if(work->owner == owner) {
normal_thread_mark(work->thread);
if (work->thread == scheme_current_thread) {
GC_mark_variable_stack(GC_variable_stack, 0, gc_stack_base);
}
}
}
inline static void clean_up_thread_list(void)
@ -1238,12 +1264,7 @@ inline static void clean_up_thread_list(void)
inline static int thread_get_owner(void *p)
{
struct thread *work;
for(work = threads; work; work = work->next)
if(work->thread == p)
return work->owner;
GCERR((GCOUTF, "Bad thread value for thread_get_owner!\n"));
return ((Scheme_Thread *)p)->gc_owner_set;
}
#endif
@ -1362,12 +1383,14 @@ inline static void reset_pointer_stack(void)
/*****************************************************************************/
#ifdef NEWGC_BTC_ACCOUNT
#define OWNER_TABLE_GROW_AMT 10
#define OWNER_TABLE_INIT_AMT 10
struct ot_entry {
Scheme_Custodian *originator;
Scheme_Custodian **members;
unsigned long memory_use;
unsigned long single_time_limit, super_required;
char limit_set, required_set;
};
static struct ot_entry **owner_table = NULL;
@ -1377,10 +1400,12 @@ static int really_doing_accounting = 0;
static int current_mark_owner = 0;
static int old_btc_mark = 0;
static int new_btc_mark = 1;
static int reset_limits = 0, reset_required = 0;
inline static int create_blank_owner_set(void)
{
int i;
unsigned int old_top;
for(i = 1; i < owner_table_top; i++)
if(!owner_table[i]) {
@ -1389,11 +1414,15 @@ inline static int create_blank_owner_set(void)
return i;
}
owner_table_top += OWNER_TABLE_GROW_AMT;
old_top = owner_table_top;
if (!owner_table_top)
owner_table_top = OWNER_TABLE_INIT_AMT;
else
owner_table_top *= 2;
owner_table = realloc(owner_table, owner_table_top*sizeof(struct ot_entry*));
bzero((char*)owner_table + (sizeof(struct ot_entry*) *
(owner_table_top - OWNER_TABLE_GROW_AMT)),
OWNER_TABLE_GROW_AMT * sizeof(struct ot_entry*));
bzero((char*)owner_table + (sizeof(struct ot_entry*) * old_top),
(owner_table_top - old_top) * sizeof(struct ot_entry*));
return create_blank_owner_set();
}
@ -1402,11 +1431,17 @@ inline static int custodian_to_owner_set(Scheme_Custodian *cust)
{
int i;
if (cust->gc_owner_set)
return cust->gc_owner_set;
for(i = 1; i < owner_table_top; i++)
if(owner_table[i] && (owner_table[i]->originator == cust))
return i;
i = create_blank_owner_set();
owner_table[i]->originator = cust;
cust->gc_owner_set = i;
return i;
}
@ -1426,6 +1461,7 @@ inline static int current_owner(Scheme_Custodian *c)
if(!has_gotten_root_custodian && c) {
has_gotten_root_custodian = 1;
owner_table[1]->originator = c;
c->gc_owner_set = 1;
return 1;
}
@ -1500,7 +1536,6 @@ inline static unsigned long custodian_usage(void *custodian)
return gcWORDS_TO_BYTES(retval);
}
inline static void memory_account_mark(struct mpage *page, void *ptr)
{
GCDEBUG((DEBUGOUTF, "memory_account_mark: %p/%p\n", page, ptr));
@ -1545,15 +1580,9 @@ inline static void mark_normal_obj(struct mpage *page, void *ptr)
unless the object's owner is the current owner. In the case
of threads, we already used it for roots, so we can just
ignore them outright. In the case of custodians, we do need
to do the check */
to do the check; those differences are handled by replacing
the mark procedure in mark_table. */
mark_table[*(unsigned short*)ptr](ptr);
/* unsigned short tag = *(unsigned short*)ptr; */
/* if(tag != scheme_thread_type) { */
/* if(tag == scheme_custodian_type) { */
/* if(custodian_to_owner_set(ptr) == current_mark_owner) */
/* mark_table[scheme_custodian_type](ptr); */
/* } else mark_table[tag](ptr); */
/* } */
break;
}
case PAGE_ATOMIC: break;
@ -1652,7 +1681,7 @@ static void do_btc_accounting(void)
for(i = 1; i < owner_table_top; i++)
if(owner_table[i])
owner_table[i]->memory_use = 0;
/* the end of the custodian list is where we want to start */
while(SCHEME_PTR1_VAL(box)) {
cur = (Scheme_Custodian*)SCHEME_PTR1_VAL(box);
@ -1704,13 +1733,20 @@ inline static void add_account_hook(int type,void *c1,void *c2,unsigned long b)
c1 = park[0]; c2 = park[1];
park[0] = park[1] = NULL;
}
if (type == MZACCT_LIMIT)
reset_limits = 1;
if (type == MZACCT_REQUIRE)
reset_required = 1;
for(work = hooks; work; work = work->next) {
if((work->type == type) && (work->c2 == c2)) {
if((work->type == type) && (work->c2 == c2) && (work->c1 == c1)) {
if(type == MZACCT_REQUIRE) {
if(b > work->amount) work->amount = b;
} else { /* (type == MZACCT_LIMIT) */
if(b < work->amount) work->amount = b;
}
break;
}
}
@ -1726,7 +1762,7 @@ inline static void clean_up_account_hooks()
struct account_hook *work = hooks, *prev = NULL;
while(work) {
if(marked(work->c1) && marked(work->c2)) {
if((!work->c1 || marked(work->c1)) && marked(work->c2)) {
work->c1 = GC_resolve(work->c1);
work->c2 = GC_resolve(work->c2);
prev = work; work = work->next;
@ -1741,13 +1777,48 @@ inline static void clean_up_account_hooks()
}
}
static unsigned long custodian_super_require(void *c)
{
int set = ((Scheme_Custodian *)c)->gc_owner_set;
if (reset_required) {
int i;
for(i = 1; i < owner_table_top; i++)
if (owner_table[i])
owner_table[i]->required_set = 0;
reset_required = 0;
}
if (!owner_table[set]->required_set) {
unsigned long req = 0, r;
struct account_hook *work = hooks;
printf("check: %p\n", c);
while(work) {
if ((work->type == MZACCT_REQUIRE) && (c == work->c2)) {
r = work->amount + custodian_super_require(work->c1);
if (r > req)
req = r;
}
work = work->next;
}
owner_table[set]->super_required = req;
owner_table[set]->required_set = 1;
}
return owner_table[set]->super_required;
}
inline static void run_account_hooks()
{
struct account_hook *work = hooks, *prev = NULL;
while(work) {
if( ((work->type == MZACCT_REQUIRE) &&
(((max_used_pages - used_pages) * APAGE_SIZE) < work->amount))
((used_pages > (max_used_pages / 2))
|| ((((max_used_pages / 2) - used_pages) * APAGE_SIZE)
< (work->amount + custodian_super_require(work->c1)))))
||
((work->type == MZACCT_LIMIT) &&
(GC_get_memory_use(work->c1) > work->amount))) {
@ -1764,6 +1835,51 @@ inline static void run_account_hooks()
}
}
static unsigned long custodian_single_time_limit(int set)
{
if (!set)
return (unsigned long)(long)-1;
if (reset_limits) {
int i;
for(i = 1; i < owner_table_top; i++)
if (owner_table[i])
owner_table[i]->limit_set = 0;
reset_limits = 0;
}
if (!owner_table[set]->limit_set) {
/* Check for limits on this custodian or one of its ancestors: */
unsigned long limit = (unsigned long)(long)-1;
Scheme_Custodian *orig = owner_table[set]->originator, *c;
struct account_hook *work = hooks;
while(work) {
if ((work->type == MZACCT_LIMIT) && (work->c1 == work->c2)) {
c = orig;
while (1) {
if (work->c2 == c) {
if (work->amount < limit)
limit = work->amount;
break;
}
if (!c->parent)
break;
c = (Scheme_Custodian*)SCHEME_PTR1_VAL(c->parent);
if (!c)
break;
}
}
work = work->next;
}
owner_table[set]->single_time_limit = limit;
owner_table[set]->limit_set = 1;
}
return owner_table[set]->single_time_limit;
}
# define set_account_hook(a,b,c,d) { add_account_hook(a,b,c,d); return 1; }
# define set_btc_mark(x) (((struct objhead *)(x))->btc_mark = old_btc_mark)
#endif
@ -1778,6 +1894,10 @@ inline static void run_account_hooks()
# define run_account_hooks() /* */
# define custodian_usage(cust) 0
# define set_btc_mark(x) /* */
static unsigned long custodian_single_time_limit(int set)
{
return (unsigned long)(long)-1;
}
#endif
int GC_set_account_hook(int type, void *c1, unsigned long b, void *c2)
@ -1954,9 +2074,10 @@ void GC_mark(const void *const_p)
/* first check to see if this is an atomic object masquerading
as a tagged object; if it is, then convert it */
if(type == PAGE_TAGGED)
if((unsigned long)mark_table[*(unsigned short*)p] < PAGE_TYPES)
if(type == PAGE_TAGGED) {
if((unsigned long)mark_table[*(unsigned short*)p] < PAGE_TYPES)
type = ohead->type = (int)(unsigned long)mark_table[*(unsigned short*)p];
}
/* now set us up for the search for where to put this thing */
work = pages[type];
@ -2001,7 +2122,7 @@ void GC_mark(const void *const_p)
((struct objhead *)newplace)->mark = 1;
/* if we're doing memory accounting, then we need the btc_mark
to be set properly */
set_btc_mark(ohead);
set_btc_mark(newplace);
/* drop the new location of the object into the forwarding space
and into the mark queue */
newplace = PTR(NUM(newplace) + WORD_SIZE);
@ -2711,7 +2832,7 @@ static void garbage_collect(int force_full)
/* printf("Collection #li (full = %i): %i / %i / %i / %i\n", number, */
/* gc_full, force_full, !generations_available, */
/* (since_last_full > 100), (memory_in_use > (2 * last_full_mem_use))); */
number++;
INIT_DEBUG_FILE(); DUMP_HEAP();

1
src/mzscheme/include/mzscheme.exp
View File

@ -427,6 +427,7 @@ scheme_host_address_strerror
scheme_getnameinfo
scheme_get_port_file_descriptor
scheme_get_port_socket
scheme_socket_to_ports
scheme_set_type_printer
scheme_print_bytes
scheme_print_utf8

1
src/mzscheme/include/mzscheme3m.exp
View File

@ -434,6 +434,7 @@ scheme_host_address_strerror
scheme_getnameinfo
scheme_get_port_file_descriptor
scheme_get_port_socket
scheme_socket_to_ports
scheme_set_type_printer
scheme_print_bytes
scheme_print_utf8

1
src/mzscheme/include/mzwin.def
View File

@ -415,6 +415,7 @@ EXPORTS
scheme_getnameinfo
scheme_get_port_file_descriptor
scheme_get_port_socket
scheme_socket_to_ports
scheme_set_type_printer
scheme_print_bytes
scheme_print_utf8

1
src/mzscheme/include/mzwin3m.def
View File

@ -426,6 +426,7 @@ EXPORTS
scheme_getnameinfo
scheme_get_port_file_descriptor
scheme_get_port_socket
scheme_socket_to_ports
scheme_set_type_printer
scheme_print_bytes
scheme_print_utf8

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

@ -1048,6 +1048,10 @@ typedef struct Scheme_Thread {
Scheme_Object *transitive_resumes; /* A hash table of running-boxes */
Scheme_Object *name;
#ifdef MZ_PRECISE_GC
int gc_owner_set;
#endif
} Scheme_Thread;
#if !SCHEME_DIRECT_EMBEDDED

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

@ -582,7 +582,11 @@ static bigdig* allocate_bigdig_array(int length)
{
int i;
bigdig* res;
res = (bigdig *)scheme_malloc_atomic(length * sizeof(bigdig));
if (length > 4096) {
res = (bigdig *)scheme_malloc_fail_ok(scheme_malloc_atomic, length * sizeof(bigdig));
} else {
res = (bigdig *)scheme_malloc_atomic(length * sizeof(bigdig));
}
for(i = 0; i < length; ++i) {
res[i] = 0;
}

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

File diff suppressed because it is too large Load Diff

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

@ -520,7 +520,7 @@ static void make_init_env(void)
scheme_add_global_constant("syntax-local-certifier",
scheme_make_prim_w_arity(local_certify,
"syntax-local-certifier",
0, 0),
0, 1),
env);
scheme_add_global_constant("make-set!-transformer",
@ -3873,18 +3873,19 @@ certifier(void *_data, int argc, Scheme_Object **argv)
}
if (cert_data[0] || cert_data[1] || cert_data[2]) {
int as_active = SCHEME_TRUEP(cert_data[3]);
s = scheme_stx_cert(s, mark,
(Scheme_Env *)(cert_data[1] ? cert_data[1] : cert_data[2]),
cert_data[0],
((argc > 1) && SCHEME_TRUEP(argv[1])) ? argv[1] : NULL,
0 /* inactive cert */);
as_active);
if (cert_data[1] && cert_data[2] && !SAME_OBJ(cert_data[1], cert_data[2])) {
/* Have module we're expanding, in addition to module that bound
the expander. */
s = scheme_stx_cert(s, mark, (Scheme_Env *)cert_data[2],
NULL,
((argc > 1) && SCHEME_TRUEP(argv[1])) ? argv[1] : NULL,
0 /* inactive cert */);
as_active);
}
}
@ -3896,19 +3897,24 @@ local_certify(int argc, Scheme_Object *argv[])
{
Scheme_Object **cert_data;
Scheme_Env *menv;
int active = 0;
if (!scheme_current_thread->current_local_env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-certifier: not currently transforming");
menv = scheme_current_thread->current_local_menv;
cert_data = MALLOC_N(Scheme_Object*, 3);
if (argc)
active = SCHEME_TRUEP(argv[0]);
cert_data = MALLOC_N(Scheme_Object*, 4);
cert_data[0] = scheme_current_thread->current_local_certs;
/* Module that bound the macro we're now running: */
cert_data[1] = (Scheme_Object *)((menv && menv->module) ? menv : NULL);
/* Module that we're currently expanding: */
menv = scheme_current_thread->current_local_env->genv;
cert_data[2] = (Scheme_Object *)((menv && menv->module) ? menv : NULL);
cert_data[3] = (active ? scheme_true : scheme_false);
return scheme_make_closed_prim_w_arity(certifier,
cert_data,

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

@ -2583,12 +2583,24 @@ typedef Scheme_Object (*Scheme_Struct_Field_Guard_Proc)(int argc, Scheme_Object
static Scheme_Object *exn_field_check(int argc, Scheme_Object **argv)
{
if (!SCHEME_IMMUTABLE_CHAR_STRINGP(argv[0]))
scheme_wrong_field_type(argv[2], "immutable string", argv[0]);
Scheme_Object *a[2], *v;
if (!SCHEME_CHAR_STRINGP(argv[0]))
scheme_wrong_field_type(argv[2], "string", argv[0]);
if (!SAME_OBJ(argv[1], TMP_CMARK_VALUE) && !SCHEME_CONT_MARK_SETP(argv[1]))
scheme_wrong_field_type(argv[2], "continuation mark set", argv[1]);
return scheme_values(2, argv);
a[0] = argv[0];
a[1] = argv[1];
if (!SCHEME_IMMUTABLE_CHAR_STRINGP(a[0])) {
v = scheme_make_immutable_sized_char_string(SCHEME_CHAR_STR_VAL(a[0]),
SCHEME_CHAR_STRLEN_VAL(a[0]),
1);
a[0] = v;
}
return scheme_values(2, a);
}
static Scheme_Object *variable_field_check(int argc, Scheme_Object **argv)

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

@ -6309,25 +6309,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
capturing the continuation, so we can jump directly. */
scheme_drop_prompt_meta_continuations(c->prompt_tag);
c->shortcut_prompt = prompt;
if ((!prompt->boundary_overflow_id && !p->overflow)
|| (prompt->boundary_overflow_id
&& (prompt->boundary_overflow_id == p->overflow->id))) {
scheme_longjmpup(&c->buf);
} else {
/* Need to unwind overflows... */
Scheme_Overflow *overflow;
overflow = p->overflow;
while (overflow->prev
&& (!overflow->prev->id
|| (overflow->prev->id != prompt->boundary_overflow_id))) {
overflow = overflow->prev;
}
/* Immediate destination is in scheme_handle_stack_overflow(). */
p->cjs.jumping_to_continuation = (Scheme_Object *)c;
p->overflow = overflow;
p->stack_start = overflow->stack_start;
scheme_longjmpup(&overflow->jmp->cont);
}
p->stack_start = c->stack_start;
scheme_longjmpup(&c->buf);
} else {
p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
p->cjs.num_vals = 1;

14
src/mzscheme/src/fun.c
View File

@ -4296,7 +4296,19 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
if (do_reset_cjs)
copy_cjs(&p->cjs, &cont->cjs);
p->overflow = cont->save_overflow;
if (shortcut_prompt) {
Scheme_Overflow *overflow;
overflow = p->overflow;
while (overflow
&& (!overflow->id
|| (overflow->id != shortcut_prompt->boundary_overflow_id))) {
overflow = overflow->prev;
}
overflow = clone_overflows(cont->save_overflow, NULL, overflow);
p->overflow = overflow;
} else {
p->overflow = cont->save_overflow;
}
{
Scheme_Meta_Continuation *mc, *resume_mc;
if (resume) {

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

@ -2494,6 +2494,25 @@ int scheme_get_port_socket(Scheme_Object *p, long *_s)
#endif
}
void scheme_socket_to_ports(long s, const char *name, int takeover,
Scheme_Object **_inp, Scheme_Object **_outp)
{
Scheme_Tcp *tcp;
Scheme_Object *v;
tcp = make_tcp_port_data(s, takeover ? 2 : 3);
v = make_tcp_input_port(tcp, name);
*_inp = v;
v = make_tcp_output_port(tcp, name);
*_outp = v;
if (takeover) {
scheme_file_open_count++;
REGISTER_SOCKET(s);
}
}
/*========================================================================*/
/* UDP */
/*========================================================================*/

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

@ -4201,26 +4201,31 @@ scheme_file_position(int argc, Scheme_Object *argv[])
#endif
} else {
if (whence == SEEK_END) {
n = is->size;
if (wis)
n = is->u.hot;
else
n = is->size;
}
if (wis) {
if (is->index > is->u.hot)
is->u.hot = is->index;
if (is->size < is->index + n) {
if (is->size < n) {
/* Expand string up to n: */
char *old;
old = is->string;
is->size = is->index + n;
{
char *ca;
ca = (char *)scheme_malloc_atomic(is->size + 1);
ca = (char *)scheme_malloc_fail_ok(scheme_malloc_atomic, n + 1);
is->string = ca;
}
memcpy(is->string, old, is->index);
}
is->size = n;
memcpy(is->string, old, is->u.hot);
}
if (n > is->u.hot)
if (n > is->u.hot) {
memset(is->string + is->u.hot, 0, n - is->u.hot);
is->u.hot = n;
}
} else {
/* Can't really move past end of read string, but pretend we do: */
if (n > is->size) {

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

@ -4848,7 +4848,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
/* Load table mapping symtab indices to stream positions: */
all_short = scheme_get_byte(port);
so = (long *)scheme_malloc_atomic(sizeof(long) * symtabsize);
so = (long *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(long) * symtabsize);
if ((got = scheme_get_bytes(port, (all_short ? 2 : 4) * (symtabsize - 1), (char *)so, 0))
!= ((all_short ? 2 : 4) * (symtabsize - 1)))
scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
@ -4892,7 +4892,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
{
unsigned char *st;
st = (unsigned char *)scheme_malloc_atomic(size + 1);
st = (unsigned char *)scheme_malloc_fail_ok(scheme_malloc_atomic, size + 1);
rp->start = st;
}
rp->pos = 0;

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

@ -835,6 +835,8 @@ MZ_EXTERN void scheme_getnameinfo(void *sa, int salen,
MZ_EXTERN int scheme_get_port_file_descriptor(Scheme_Object *p, long *_fd);
MZ_EXTERN int scheme_get_port_socket(Scheme_Object *p, long *_s);
MZ_EXTERN void scheme_socket_to_ports(long s, const char *name, int takeover,
Scheme_Object **_inp, Scheme_Object **_outp);
MZ_EXTERN void scheme_set_type_printer(Scheme_Type stype, Scheme_Type_Printer printer);
MZ_EXTERN void scheme_print_bytes(Scheme_Print_Params *pp, const char *str, int offset, int len);

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

@ -699,6 +699,8 @@ void (*scheme_getnameinfo)(void *sa, int salen,
char *serv, int servlen);
int (*scheme_get_port_file_descriptor)(Scheme_Object *p, long *_fd);
int (*scheme_get_port_socket)(Scheme_Object *p, long *_s);
void (*scheme_socket_to_ports)(long s, const char *name, int takeover,
Scheme_Object **_inp, Scheme_Object **_outp);
void (*scheme_set_type_printer)(Scheme_Type stype, Scheme_Type_Printer printer);
void (*scheme_print_bytes)(Scheme_Print_Params *pp, const char *str, int offset, int len);
void (*scheme_print_utf8)(Scheme_Print_Params *pp, const char *str, int offset, int len);

1
src/mzscheme/src/schemex.inc
View File

@ -476,6 +476,7 @@
scheme_extension_table->scheme_getnameinfo = scheme_getnameinfo;
scheme_extension_table->scheme_get_port_file_descriptor = scheme_get_port_file_descriptor;
scheme_extension_table->scheme_get_port_socket = scheme_get_port_socket;
scheme_extension_table->scheme_socket_to_ports = scheme_socket_to_ports;
scheme_extension_table->scheme_set_type_printer = scheme_set_type_printer;
scheme_extension_table->scheme_print_bytes = scheme_print_bytes;
scheme_extension_table->scheme_print_utf8 = scheme_print_utf8;

1
src/mzscheme/src/schemexm.h
View File

@ -476,6 +476,7 @@
#define scheme_getnameinfo (scheme_extension_table->scheme_getnameinfo)
#define scheme_get_port_file_descriptor (scheme_extension_table->scheme_get_port_file_descriptor)
#define scheme_get_port_socket (scheme_extension_table->scheme_get_port_socket)
#define scheme_socket_to_ports (scheme_extension_table->scheme_socket_to_ports)
#define scheme_set_type_printer (scheme_extension_table->scheme_set_type_printer)
#define scheme_print_bytes (scheme_extension_table->scheme_print_bytes)
#define scheme_print_utf8 (scheme_extension_table->scheme_print_utf8)

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

@ -358,6 +358,10 @@ struct Scheme_Custodian {
Scheme_Custodian_Reference *global_next;
Scheme_Custodian_Reference *global_prev;
#ifdef MZ_PRECISE_GC
int gc_owner_set;
#endif
};
Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_Func f);

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 369
#define MZSCHEME_VERSION_MINOR 4
#define MZSCHEME_VERSION_MINOR 5
#define MZSCHEME_VERSION "369.4" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "369.5" _MZ_SPECIAL_TAG

2
src/mzscheme/src/startup.inc
View File

@ -652,7 +652,7 @@
"((fields)(cdddr defined-names))"
"((wrap)(if gen-expr?(lambda(x)(cons 'list-immutable x)) values))"
"((total-wrap)(if gen-expr?"
"(lambda(x) `(let((,cert-id(syntax-local-certifier))) ,x))"
"(lambda(x) `(let((,cert-id(syntax-local-certifier #t))) ,x))"
" values)))"
"(total-wrap"
"(wrap"

2
src/mzscheme/src/startup.ss
View File

@ -761,7 +761,7 @@
[(fields) (cdddr defined-names)]
[(wrap) (if gen-expr? (lambda (x) (cons 'list-immutable x)) values)]
[(total-wrap) (if gen-expr?
(lambda (x) `(let ([,cert-id (syntax-local-certifier)]) ,x))
(lambda (x) `(let ([,cert-id (syntax-local-certifier #t)]) ,x))
values)])
(total-wrap
(wrap

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

@ -241,6 +241,25 @@ static int recycle_cc_count;
static mz_jmp_buf main_init_error_buf;
#ifdef MZ_PRECISE_GC
/* This is a trick to get the types right. Note that
the layout of the weak box is defined by the
GC spec. */
typedef struct {
short type;
short hash_key;
Scheme_Custodian *val;
} Scheme_Custodian_Weak_Box;
# define MALLOC_MREF() (Scheme_Custodian_Reference *)scheme_make_weak_box(NULL)
# define CUSTODIAN_FAM(x) ((Scheme_Custodian_Weak_Box *)x)->val
# define xCUSTODIAN_FAM(x) SCHEME_BOX_VAL(x)
#else
# define MALLOC_MREF() MALLOC_ONE_WEAK(Scheme_Custodian_Reference)
# define CUSTODIAN_FAM(x) (*(x))
# define xCUSTODIAN_FAM(x) (*(x))
#endif
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
@ -670,12 +689,12 @@ void scheme_init_thread(Scheme_Env *env)
scheme_add_global_constant("custodian-require-memory",
scheme_make_prim_w_arity(custodian_require_mem,
"custodian-require-memory",
2, 2),
3, 3),
env);
scheme_add_global_constant("custodian-limit-memory",
scheme_make_prim_w_arity(custodian_limit_mem,
"custodian-limit-memory",
3, 3),
2, 3),
env);
@ -836,23 +855,45 @@ static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[])
static Scheme_Object *custodian_require_mem(int argc, Scheme_Object *args[])
{
long lim;
Scheme_Custodian *c1, *c2, *cx;
if (SCHEME_INTP(args[0]) && (SCHEME_INT_VAL(args[0]) > 0)) {
lim = SCHEME_INT_VAL(args[0]);
} else if (SCHEME_BIGNUMP(args[0]) && SCHEME_BIGPOS(args[0])) {
lim = 0x3fffffff; /* more memory than we actually have */
} else {
scheme_wrong_type("custodian-require-memory", "positive exact integer", 0, argc, args);
if(NOT_SAME_TYPE(SCHEME_TYPE(args[0]), scheme_custodian_type)) {
scheme_wrong_type("custodian-require-memory", "custodian", 0, argc, args);
return NULL;
}
if(NOT_SAME_TYPE(SCHEME_TYPE(args[1]), scheme_custodian_type)) {
scheme_wrong_type("custodian-require-memory", "custodian", 1, argc, args);
if (SCHEME_INTP(args[1]) && (SCHEME_INT_VAL(args[1]) > 0)) {
lim = SCHEME_INT_VAL(args[1]);
} else if (SCHEME_BIGNUMP(args[1]) && SCHEME_BIGPOS(args[1])) {
lim = 0x3fffffff; /* more memory than we actually have */
} else {
scheme_wrong_type("custodian-require-memory", "positive exact integer", 1, argc, args);
return NULL;
}
if(NOT_SAME_TYPE(SCHEME_TYPE(args[2]), scheme_custodian_type)) {
scheme_wrong_type("custodian-require-memory", "custodian", 2, argc, args);
return NULL;
}
c1 = (Scheme_Custodian *)args[0];
c2 = (Scheme_Custodian *)args[2];
/* Check whether c1 is super to c2: */
if (c1 == c2) {
cx = NULL;
} else {
for (cx = c2; cx && NOT_SAME_OBJ(cx, c1); ) {
cx = CUSTODIAN_FAM(cx->parent);
}
}
if (!cx) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"custodian-require-memory: second custodian is not a sub-custodian of the first custodian");
}
#ifdef MZ_PRECISE_GC
if (GC_set_account_hook(MZACCT_REQUIRE, NULL, lim, args[1]))
if (GC_set_account_hook(MZACCT_REQUIRE, c1, lim, c2))
return scheme_void;
#endif
@ -876,15 +917,18 @@ static Scheme_Object *custodian_limit_mem(int argc, Scheme_Object *args[])
lim = 0x3fffffff; /* more memory than we actually have */
} else {
scheme_wrong_type("custodian-limit-memory", "positive exact integer", 1, argc, args);
}
if(NOT_SAME_TYPE(SCHEME_TYPE(args[2]), scheme_custodian_type)) {
scheme_wrong_type("custodian-require-memory", "custodian", 2, argc, args);
return NULL;
}
if (argc > 2) {
if (NOT_SAME_TYPE(SCHEME_TYPE(args[2]), scheme_custodian_type)) {
scheme_wrong_type("custodian-require-memory", "custodian", 2, argc, args);
return NULL;
}
}
#ifdef MZ_PRECISE_GC
if (GC_set_account_hook(MZACCT_LIMIT, args[0], SCHEME_INT_VAL(args[1]), args[2]))
if (GC_set_account_hook(MZACCT_LIMIT, args[0], lim, (argc > 2) ? args[2] : args[0]))
return scheme_void;
#endif
@ -979,25 +1023,6 @@ static void add_managed_box(Scheme_Custodian *m,
m->count++;
}
#ifdef MZ_PRECISE_GC
/* This is a trick to get the types right. Note that
the layout of the weak box is defined by the
GC spec. */
typedef struct {
short type;
short hash_key;
Scheme_Custodian *val;
} Scheme_Custodian_Weak_Box;
# define MALLOC_MREF() (Scheme_Custodian_Reference *)scheme_make_weak_box(NULL)
# define CUSTODIAN_FAM(x) ((Scheme_Custodian_Weak_Box *)x)->val
# define xCUSTODIAN_FAM(x) SCHEME_BOX_VAL(x)
#else
# define MALLOC_MREF() MALLOC_ONE_WEAK(Scheme_Custodian_Reference)
# define CUSTODIAN_FAM(x) (*(x))
# define xCUSTODIAN_FAM(x) (*(x))
#endif
static void remove_managed(Scheme_Custodian_Reference *mr, Scheme_Object *o,
Scheme_Close_Custodian_Client **old_f, void **old_data)
{
@ -5924,7 +5949,7 @@ static void make_initial_config(Scheme_Thread *p)
init_param(cells, paramz, MZCONFIG_DELAY_LOAD_INFO, scheme_false);
init_param(cells, paramz, MZCONFIG_PRINT_GRAPH, scheme_false);
init_param(cells, paramz, MZCONFIG_PRINT_STRUCT, scheme_false);
init_param(cells, paramz, MZCONFIG_PRINT_STRUCT, scheme_true);
init_param(cells, paramz, MZCONFIG_PRINT_BOX, scheme_true);
init_param(cells, paramz, MZCONFIG_PRINT_VEC_SHORTHAND, scheme_true);
init_param(cells, paramz, MZCONFIG_PRINT_HASH_TABLE, scheme_false);
@ -5947,7 +5972,7 @@ static void make_initial_config(Scheme_Thread *p)
init_param(cells, paramz, MZCONFIG_CURLY_BRACES_ARE_PARENS, (scheme_curly_braces_are_parens
? scheme_true : scheme_false));
init_param(cells, paramz, MZCONFIG_ERROR_PRINT_WIDTH, scheme_make_integer(100));
init_param(cells, paramz, MZCONFIG_ERROR_PRINT_WIDTH, scheme_make_integer(256));
init_param(cells, paramz, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, scheme_make_integer(16));
init_param(cells, paramz, MZCONFIG_ERROR_PRINT_SRCLOC, scheme_true);
@ -6733,6 +6758,7 @@ static void done_with_GC()
#ifdef RUNSTACK_IS_GLOBAL
# ifdef MZ_PRECISE_GC
MZ_RUNSTACK = scheme_current_thread->runstack;
MZ_RUNSTACK_START = scheme_current_thread->runstack_start;
# endif
#endif
#ifdef WINDOWS_PROCESSES

3
src/wxcommon/PSDC.cxx
View File

@ -2324,6 +2324,7 @@ Bool wxPrintSetupData::ShowNative(wxWindow *parent)
if (!native) {
native = new WXGC_PTRS wxPrintData();
native->SetLandscape(printer_orient == PS_LANDSCAPE);
native->SetScale(printer_scale_y);
}
d = new WXGC_PTRS wxPrintDialog(parent, native);
@ -2333,6 +2334,8 @@ Bool wxPrintSetupData::ShowNative(wxWindow *parent)
if (ok) {
ls = native->GetLandscape();
printer_orient = (ls ? PS_LANDSCAPE : PS_PORTRAIT);
printer_scale_y = native->GetScale();
printer_scale_x = printer_scale_y;
}
return ok;
#else

3
src/wxmac/include/mac/wx_print.h
View File

@ -102,6 +102,9 @@ class wxPrintData: public wxObject
void SetLandscape(Bool);
Bool GetLandscape();
void SetScale(double s);
double GetScale();
wxPrintData *copy();
};

5
src/wxmac/src/mac/wx_dcpr1.cc
View File

@ -35,6 +35,11 @@ wxPrinterDC::wxPrinterDC(wxPrintData *printData, Bool interactive) : wxCanvasDC(
printData = new WXGC_PTRS wxPrintData();
if (ps->GetPrinterOrientation() == PS_LANDSCAPE)
printData->SetLandscape(TRUE);
{
double sx, sy;
ps->GetPrinterScaling(&sx, &sy);
printData->SetScale(sy);
}
}
}

27
src/wxmac/src/mac/wx_print.cc
View File

@ -261,6 +261,18 @@ Bool wxPrintData::GetLandscape()
return ((o == kPMLandscape) || (o == kPMReverseLandscape));
}
void wxPrintData::SetScale(double s)
{
PMSetScale(cPageFormat, s * 100);
}
double wxPrintData::GetScale()
{
double s;
PMGetScale(cPageFormat, &s);
return s / 100;
}
wxPrintData *wxPrintData::copy(void)
{
wxPrintData *pd;
@ -303,11 +315,24 @@ Bool wxPrinter::Print(wxWindow *parent, wxPrintout *printout, Bool prompt)
int copyCount;
double w, h;
wxDC* dc;
wxPrintSetupData *ps;
if (!printout)
return FALSE;
printData = new WXGC_PTRS wxPrintData();
ps = wxGetThePrintSetupData();
if (ps->native) {
printData = ps->native->copy();
} else {
printData = new WXGC_PTRS wxPrintData();
if (ps->GetPrinterOrientation() == PS_LANDSCAPE)
printData->SetLandscape(TRUE);
{
double sx, sy;
ps->GetPrinterScaling(&sx, &sy);
printData->SetScale(sy);
}
}
printout->SetIsPreview(FALSE);
printout->OnPreparePrinting();