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

Another day, another sync.

Browse Source 
svn: r12887
This commit is contained in:
Stevie Strickland 2008-12-18 15:24:18 +00:00
commit 48ea3995b4
47 changed files with 722 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -94,10 +94,10 @@
(number? (car x))
(number? (cdr x))))))
(preferences:set-default 'drscheme:memory-limit (* 1024 1024 128)
(preferences:set-default 'drscheme:child-only-memory-limit (* 1024 1024 128)
(λ (x) (or (boolean? x)
(integer? x)
(x . >= . (* 1024 1024 100)))))
(x . >= . (* 1024 1024 1)))))
(preferences:set-default 'drscheme:recent-language-names
null

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

@ -867,7 +867,7 @@ TODO
(memory-killed-thread #f)
(user-custodian #f)
(custodian-limit (and (custodian-memory-accounting-available?)
(preferences:get 'drscheme:memory-limit)))
(preferences:get 'drscheme:child-only-memory-limit)))
(user-eventspace-box (make-weak-box #f))
(user-namespace-box (make-weak-box #f))
(user-eventspace-main-thread #f)
@ -925,7 +925,7 @@ TODO
(field (need-interaction-cleanup? #f))
(define/private (no-user-evaluation-message frame exit-code memory-killed?)
(let* ([new-limit (and custodian-limit (+ (* 1024 1024 128) custodian-limit))]
(let* ([new-limit (and custodian-limit (+ custodian-limit custodian-limit))]
[ans (message-box/custom
(string-constant evaluation-terminated)
(string-append
@ -953,7 +953,7 @@ TODO
)])
(when (equal? ans 3)
(set-custodian-limit new-limit)
(preferences:set 'drscheme:memory-limit new-limit))
(preferences:set 'drscheme:child-only-memory-limit new-limit))
(set-insertion-point (last-position))
(insert-warning "\nInteractions disabled")))

8
collects/drscheme/private/unit.ss
View File

@ -3292,10 +3292,10 @@ module browser threading seems wrong.
(when num
(cond
[(eq? num #t)
(preferences:set 'drscheme:memory-limit #f)
(preferences:set 'drscheme:child-only-memory-limit #f)
(send interactions-text set-custodian-limit #f)]
[else
(preferences:set 'drscheme:memory-limit
(preferences:set 'drscheme:child-only-memory-limit
(* 1024 1024 num))
(send interactions-text set-custodian-limit
(* 1024 1024 num))]))))]))
@ -3844,7 +3844,7 @@ module browser threading seems wrong.
[parent hp]
[init-value (if current-limit
(format "~a" current-limit)
"128")]
"64")]
[stretchable-width #f]
[min-width 100]
[callback
@ -3886,7 +3886,7 @@ module browser threading seems wrong.
(let* ([n (string->number (send txt get-text))])
(and n
(integer? n)
(100 . <= . n))))
(1 . <= . n))))
(define (background sd)
(let ([txt (send tb get-editor)])

20
collects/html/html.scrbl
View File

@ -4,8 +4,9 @@
(for-label html)
(for-label xml))
@title{@bold{HTML}: Parsing Library}
@(define xexpr @tech[#:doc '(lib "xml/xml.scrbl")]{X-expression})
@title{@bold{HTML}: Parsing Library}
@defmodule[html]{The @schememodname[html] library provides
functions to read html documents and structures to represent them.}
@ -25,12 +26,27 @@ Reads (X)HTML from a port, producing an @scheme[html] instance.}
@defproc[(read-html-as-xml [port input-port?])
(listof content?)]{
Reads HTML from a port, producing an xexpr compatible with the
Reads HTML from a port, producing an @xexpr compatible with the
@schememodname[xml] library (which defines @scheme[content?]).}
@defboolparam[read-html-comments v]{
If @scheme[v] is not @scheme[#f], then comments are read and returned. Defaults to @scheme[#f].
}
@defboolparam[use-html-spec v]{
If @scheme[v] is not @scheme[#f], then the HTML must respect the HTML specification
with regards to what elements are allowed to be the children of
other elements. For example, the top-level @scheme["<html>"]
element may only contain a @scheme["<body>"] and @scheme["<head>"]
element. Defaults to @scheme[#f].
}
@section{Example}
@(require (only-in (for-label scheme)
open-input-string string-append
list cond match apply append map printf define require module)
(for-label (prefix-in h: html))
(for-label (prefix-in x: xml)))
@def+int[
(module html-example scheme

2
collects/mzlib/foreign.ss
View File

@ -1500,7 +1500,7 @@
;; Used by set-ffi-obj! to get the actual value so it can be kept around
(define (get-lowlevel-object x type)
(let ([basetype (ctype-basetype type)])
(if basetype
(if (ctype? basetype)
(let ([s->c (ctype-scheme->c type)])
(get-lowlevel-object (if s->c (s->c x) x) basetype))
(values x type))))

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "14dec2008")
#lang scheme/base (provide stamp) (define stamp "18dec2008")

247
collects/scheme/sandbox.ss
View File

@ -25,10 +25,13 @@
sandbox-make-logger
sandbox-memory-limit
sandbox-eval-limits
sandbox-eval-handlers
call-with-trusted-sandbox-configuration
evaluator-alive?
kill-evaluator
break-evaluator
set-eval-limits
set-eval-handler
put-input
get-output
get-error-output
@ -39,6 +42,8 @@
call-in-nested-thread*
call-with-limits
with-limits
call-with-custodian-shutdown
call-with-killing-threads
exn:fail:sandbox-terminated?
exn:fail:sandbox-terminated-reason
exn:fail:resource?
@ -58,11 +63,23 @@
(define sandbox-output (make-parameter #f))
(define sandbox-error-output
(make-parameter (lambda () (dup-output-port (current-error-port)))))
(define sandbox-memory-limit (make-parameter 20)) ; 30mb total
(define sandbox-memory-limit (make-parameter 30)) ; 30mb total
(define sandbox-eval-limits (make-parameter '(30 20))) ; 30sec, 20mb
(define sandbox-propagate-breaks (make-parameter #t))
(define sandbox-coverage-enabled (make-parameter #f))
(define (call-with-trusted-sandbox-configuration thunk)
(parameterize ([sandbox-propagate-breaks #t]
[sandbox-override-collection-paths '()]
[sandbox-security-guard current-security-guard]
[sandbox-exit-handler (exit-handler)]
[sandbox-make-inspector current-inspector]
[sandbox-make-code-inspector current-code-inspector]
[sandbox-make-logger current-logger]
[sandbox-memory-limit #f]
[sandbox-eval-limits #f])
(thunk)))
(define sandbox-namespace-specs
(make-parameter `(,(mz/mr make-base-namespace make-gui-namespace)
#| no modules here by default |#)))
@ -94,9 +111,14 @@
[(string? path) (string->path path)]
[else path]))))))
(define permission-order '(execute write delete read exists))
;; 'read-bytecode is special, it's higher than 'read, but not lower than
;; 'delete.
(define permission-order '(execute write delete read-bytecode read exists))
(define (perm<=? p1 p2)
(memq p1 (memq p2 permission-order)))
(or (eq? p1 p2)
(and (not (eq? 'read-bytecode p1))
(memq p1 (memq p2 permission-order))
#t)))
;; gets a path (can be bytes/string), returns a regexp for that path that
;; matches also subdirs (if it's a directory)
@ -117,6 +139,29 @@
(map (lambda (perm) (list (car perm) (path->bregexp (cadr perm))))
new))))
;; compresses the (sandbox-path-permissions) value to a "compressed" list of
;; (permission regexp ...) where each permission appears exactly once (so it's
;; quicker to test it later, no need to scan the whole permission list).
(define compressed-path-permissions
(let ([t (make-weak-hasheq)])
(define (compress-permissions ps)
(map (lambda (perm)
(let* ([ps (filter (lambda (p) (perm<=? perm (car p))) ps)]
[ps (remove-duplicates (map cadr ps))])
(cons perm ps)))
permission-order))
(lambda ()
(let ([ps (sandbox-path-permissions)])
(or (hash-ref t ps #f)
(let ([c (compress-permissions ps)]) (hash-set! t ps c) c))))))
;; similar to the security guard, only with a single mode for simplification;
;; assumes valid mode and simplified path
(define (check-sandbox-path-permissions path needed)
(let ([bpath (path->bytes path)]
[perms (compressed-path-permissions)])
(ormap (lambda (rx) (regexp-match? rx bpath)) (cdr (assq needed perms)))))
(define sandbox-network-guard
(make-parameter (lambda (what . xs)
(error what "network access denied: ~e" xs))))
@ -127,16 +172,17 @@
orig-security
(lambda (what path modes)
(when path
(let ([needed (car (or (for/or ([p (in-list permission-order)])
(memq p modes))
(error 'default-sandbox-guard
"unknown access modes: ~e" modes)))]
[bpath (parameterize ([current-security-guard orig-security])
(path->bytes (simplify-path* path)))])
(unless (ormap (lambda (perm)
(and (perm<=? needed (car perm))
(regexp-match (cadr perm) bpath)))
(sandbox-path-permissions))
(let ([spath (parameterize ([current-security-guard orig-security])
(simplify-path* path))]
[maxperm
;; assumes that the modes are valid (ie, in the above list)
(cond [(null? modes) (error 'default-sandbox-guard
"got empty mode list for ~e and ~e"
what path)]
[(null? (cdr modes)) (car modes)] ; common case
[else (foldl (lambda (x max) (if (perm<=? max x) x max))
(car modes) (cdr modes))])])
(unless (check-sandbox-path-permissions spath maxperm)
(error what "`~a' access denied for ~a"
(string-append* (add-between (map symbol->string modes) "+"))
path)))))
@ -168,8 +214,8 @@
(append (map (lambda (p) `(read ,(path->bytes p))) paths)
(module-specs->path-permissions require-perms))))
;; computes permissions that are needed for require specs (`read' for all
;; files and "compiled" subdirs, `exists' for the base-dir)
;; computes permissions that are needed for require specs (`read-bytecode' for
;; all files and "compiled" subdirs, `exists' for the base-dir)
(define (module-specs->path-permissions mods)
(define paths (module-specs->non-lib-paths mods))
(define bases
@ -180,8 +226,8 @@
(let ([base (simplify-path* base)])
(loop (cdr paths)
(if (member base bases) bases (cons base bases))))))))
(append (map (lambda (p) `(read ,p)) paths)
(map (lambda (b) `(read ,(build-path b "compiled"))) bases)
(append (map (lambda (p) `(read-bytecode ,p)) paths)
(map (lambda (b) `(read-bytecode ,(build-path b "compiled"))) bases)
(map (lambda (b) `(exists ,b)) bases)))
;; takes a module-spec list and returns all module paths that are needed
@ -273,7 +319,8 @@
(define-values (cust cust-box)
(if (and mb memory-accounting?)
(let ([c (make-custodian (current-custodian))])
(custodian-limit-memory c (* mb 1024 1024) c)
(custodian-limit-memory
c (inexact->exact (round (* mb 1024 1024))) c)
(values c (make-custodian-box c #t)))
(values (current-custodian) #f)))
(parameterize ([current-custodian cust])
@ -282,7 +329,9 @@
;; time limit
(when sec
(let ([t (current-thread)])
(thread (lambda () (sleep sec) (set! r 'time) (kill-thread t)))))
(thread (lambda ()
(unless (sync/timeout sec t) (set! r 'time))
(kill-thread t)))))
(set! r (with-handlers ([void (lambda (e) (list raise e))])
(call-with-values thunk (lambda vs (list* values vs))))))
;; The thread might be killed by the timer thread, so don't let
@ -317,6 +366,28 @@
[(with-limits sec mb body ...)
(call-with-limits sec mb (lambda () body ...))]))
;; other resource utilities
(define (call-with-custodian-shutdown thunk)
(let ([cust (make-custodian (current-custodian))])
(dynamic-wind
void
(lambda () (parameterize ([current-custodian cust]) (thunk)))
(lambda () (custodian-shutdown-all cust)))))
(define (call-with-killing-threads thunk)
(let* ([cur (current-custodian)] [sub (make-custodian cur)])
(define (kill-all x)
(cond [(custodian? x) (for-each kill-all (custodian-managed-list x cur))]
[(thread? x) (kill-thread x)]))
(dynamic-wind
void
(lambda () (parameterize ([current-custodian sub]) (thunk)))
(lambda () (kill-all sub)))))
(define sandbox-eval-handlers
(make-parameter (list #f call-with-custodian-shutdown)))
;; Execution ----------------------------------------------------------------
(define (literal-identifier=? x y)
@ -510,12 +581,14 @@
(define-evaluator-messenger kill-evaluator 'kill)
(define-evaluator-messenger break-evaluator 'break)
(define-evaluator-messenger (set-eval-limits secs mb) 'limits)
(define-evaluator-messenger (set-eval-handler handler) 'handler)
(define-evaluator-messenger (put-input . xs) 'input)
(define-evaluator-messenger get-output 'output)
(define-evaluator-messenger get-error-output 'error-output)
(define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
(define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk)
(define (call-in-sandbox-context evaluator thunk [unrestricted? #f])
(evaluator (make-evaluator-message (if unrestricted? 'thunk* 'thunk)
(list thunk))))
(define-struct (exn:fail:sandbox-terminated exn:fail) (reason) #:transparent)
(define (make-terminated reason)
@ -526,6 +599,7 @@
(define (make-evaluator* init-hook allow program-maker)
(define orig-code-inspector (current-code-inspector))
(define orig-security-guard (current-security-guard))
(define orig-cust (current-custodian))
(define memory-cust (make-custodian orig-cust))
(define memory-cust-box (make-custodian-box memory-cust #t))
@ -539,24 +613,33 @@
(define output #f)
(define error-output #f)
(define limits (sandbox-eval-limits))
(define eval-handler (car (sandbox-eval-handlers))) ; 1st handler on startup
(define user-thread #t) ; set later to the thread
(define user-done-evt #t) ; set in the same place
(define terminated? #f) ; set to an exception value when the sandbox dies
(define (limit-thunk thunk)
(let* ([sec (and limits (car limits))]
[mb (and limits (cadr limits))]
[thunk (if (or sec mb)
(lambda () (call-with-limits sec mb thunk))
thunk)]
[thunk (if eval-handler (lambda () (eval-handler thunk)) thunk)])
thunk))
(define (terminated! reason)
(unless terminated?
(set! terminated?
(make-terminated
(cond [(eq? reason #t) ; => guess
(if (custodian-box-value user-cust-box)
'thread-killed
'custodian-shutdown)]
[reason reason] ; => explicit
;; otherwise it's an indication of an internal error
[else "internal error: no termination reason"])))))
(define (limit-thunk thunk)
(let* ([sec (and limits (car limits))]
[mb (and limits (cadr limits))])
(if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk)))
(cond
;; #f is used as an indication of an internal error, when we
;; don't know why the sandbox is killed
[(not reason) "internal error: no termination reason"]
;; explicit reason given
[(not (eq? reason #t)) reason]
;; reason = #t => guess the reason
[(not (custodian-box-value memory-cust-box)) 'out-of-memory]
[(not (custodian-box-value user-cust-box)) 'custodian-shutdown]
[(thread-dead? user-thread) 'thread-killed]
[else "internal error: cannot guess termination reason"])))))
(define (user-kill)
(when user-thread
(let ([t user-thread])
@ -565,6 +648,10 @@
(custodian-shutdown-all user-cust)
(kill-thread t))) ; just in case
(void))
(define (terminate+kill! reason raise?)
(terminated! reason)
(user-kill)
(when raise? (raise terminated?)))
(define (user-break)
(when user-thread (break-thread user-thread)))
(define (user-process)
@ -578,6 +665,7 @@
limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get))))
(channel-put result-ch 'ok))
(set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
;; finally wait for interaction expressions
(let ([n 0])
(let loop ()
@ -587,36 +675,34 @@
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
(define run
(limit-thunk (if (evaluator-message? expr)
(lambda ()
(apply (evaluator-message-msg expr)
(evaluator-message-args expr)))
(lambda ()
(if (evaluator-message? expr)
(case (evaluator-message-msg expr)
[(thunk) (limit-thunk (car (evaluator-message-args expr)))]
[(thunk*) (car (evaluator-message-args expr))]
[else (error 'sandbox "internal error (bad message)")])
(limit-thunk (lambda ()
(set! n (add1 n))
(eval* (input->code (list expr) 'eval n))))))
(channel-put result-ch (cons 'vals (call-with-values run list))))
(loop)))))
(define (get-user-result)
(with-handlers ([(if (sandbox-propagate-breaks) exn:break? (lambda (_) #f))
(lambda (e) (user-break) (get-user-result))])
(sync user-done-evt result-ch)))
(define (user-eval expr)
;; the thread will usually be running, but it might be killed outside of
;; the sandboxed environment, for example, if you do something like
;; (kill-thread (ev '(current-thread))) when there are no per-expression
;; limits (since then you get a different thread, which is already dead).
(when (and user-thread (thread-dead? user-thread))
(terminated! #t))
(terminate+kill! #t #t))
(cond
[terminated? => raise]
[(not user-thread) (error 'sandbox "internal error (user-thread is #f)")]
[else
(channel-put input-ch expr)
(let ([r (let loop ()
(with-handlers ([(if (sandbox-propagate-breaks)
exn:break? (lambda (_) #f))
(lambda (e) (user-break) (loop))])
(sync user-done-evt result-ch)))])
(cond [(eof-object? r)
(terminated! (and (not (custodian-box-value memory-cust-box))
'out-of-memory))
(raise terminated?)]
(let ([r (get-user-result)])
(cond [(eof-object? r) (terminate+kill! #t #t)]
[(eq? (car r) 'exn) (raise (cdr r))]
[else (apply values (cdr r))]))]))
(define get-uncovered
@ -631,7 +717,7 @@
(filter (lambda (x) (equal? src (syntax-source x))) uncovered)
uncovered))]))
(define (output-getter p)
(if (procedure? p) (user-eval (make-evaluator-message p '())) p))
(if (procedure? p) (user-eval (make-evaluator-message 'thunk (list p))) p))
(define input-putter
(case-lambda
[() (input-putter input)]
@ -645,16 +731,16 @@
(if (evaluator-message? expr)
(let ([msg (evaluator-message-msg expr)])
(case msg
[(alive?) (and user-thread (not (thread-dead? user-thread)))]
[(kill) (terminated! 'evaluator-killed) (user-kill)]
[(break) (user-break)]
[(limits) (set! limits (evaluator-message-args expr))]
[(input) (apply input-putter (evaluator-message-args expr))]
[(output) (output-getter output)]
[(alive?) (and user-thread (not (thread-dead? user-thread)))]
[(kill) (terminate+kill! 'evaluator-killed #f)]
[(break) (user-break)]
[(limits) (set! limits (evaluator-message-args expr))]
[(handler) (set! eval-handler (car (evaluator-message-args expr)))]
[(input) (apply input-putter (evaluator-message-args expr))]
[(output) (output-getter output)]
[(error-output) (output-getter error-output)]
[(uncovered) (apply get-uncovered (evaluator-message-args expr))]
[(thunk) (user-eval (make-evaluator-message
(car (evaluator-message-args expr)) '()))]
[(thunk thunk*) (user-eval expr)]
[else (error 'evaluator "internal error, bad message: ~e" msg)]))
(user-eval expr)))
(define (make-output what out set-out! allow-link?)
@ -679,7 +765,9 @@
;; set global memory limit
(when (and memory-accounting? (sandbox-memory-limit))
(custodian-limit-memory
memory-cust (* (sandbox-memory-limit) 1024 1024) memory-cust))
memory-cust
(inexact->exact (round (* (sandbox-memory-limit) 1024 1024)))
memory-cust))
(parameterize* ; the order in these matters
(;; create a sandbox context first
[current-custodian user-cust]
@ -707,33 +795,41 @@
(append (sandbox-override-collection-paths)
(current-library-collection-paths)))]
[sandbox-path-permissions
(append (map (lambda (p) `(read ,p))
(current-library-collection-paths))
(compute-permissions allow)
(sandbox-path-permissions))]
`(,@(map (lambda (p) `(read-bytecode ,p))
(current-library-collection-paths))
(exists ,(find-system-path 'addon-dir))
,@(compute-permissions allow)
,@(sandbox-path-permissions))]
;; general info
[current-command-line-arguments '#()]
;; restrict the sandbox context from this point
[current-security-guard
(let ([g (sandbox-security-guard)]) (if (security-guard? g) g (g)))]
[exit-handler
(let ([h (sandbox-exit-handler)])
(if (eq? h default-sandbox-exit-handler)
(lambda _ (terminated! 'exited) (user-kill))
h))]
[current-inspector ((sandbox-make-inspector))]
[current-logger ((sandbox-make-logger))]
[current-code-inspector (make-inspector)]
[current-inspector ((sandbox-make-inspector))]
[current-code-inspector ((sandbox-make-code-inspector))]
;; The code inspector serves two purposes -- making sure that only trusted
;; byte-code is loaded, and avoiding using protected moduel bindings, like
;; the foreign library's `unsafe!'. We don't need the first because we
;; control it indirectly through the security guard, so this handler makes
;; sure that byte-code is loaded using the original inspector.
;; byte-code is loaded, and avoiding using protected module bindings, like
;; the foreign library's `unsafe!'. We control the first through the path
;; permissions -- using the 'read-bytecode permissionn level, so this
;; handler just checks for that permission then goes on to load the file
;; using the original inspector.
[current-load/use-compiled
(let ([handler (current-load/use-compiled)])
(lambda (path modname)
(parameterize ([current-code-inspector orig-code-inspector])
(if (check-sandbox-path-permissions
(parameterize ([current-security-guard orig-security-guard])
(simplify-path* path))
'read-bytecode)
(parameterize ([current-code-inspector orig-code-inspector])
(handler path modname))
;; otherwise, just let the old handler throw a proper error
(handler path modname))))]
[exit-handler
(let ([h (sandbox-exit-handler)])
(if (eq? h default-sandbox-exit-handler)
(lambda _ (terminate+kill! 'exited #f))
h))]
;; Note the above definition of `current-eventspace': in MzScheme, it
;; is an unused parameter. Also note that creating an eventspace
;; starts a thread that will eventually run the callback code (which
@ -742,10 +838,9 @@
;; it will not use the new namespace.
[current-eventspace (make-eventspace)])
(let ([t (bg-run->thread (run-in-bg user-process))])
(set! user-done-evt
(handle-evt t (lambda (_) (terminated! #t) (user-kill) eof)))
(set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t))))
(set! user-thread t))
(let ([r (channel-get result-ch)])
(let ([r (get-user-result)])
(if (eq? r 'ok)
;; initial program executed ok, so return an evaluator
evaluator

14
collects/scribble/eval.ss
View File

@ -239,18 +239,16 @@
[else stx]))
(define (make-base-eval)
(parameterize ([sandbox-security-guard (current-security-guard)]
[sandbox-output 'string]
[sandbox-error-output 'string]
[sandbox-eval-limits #f]
[sandbox-memory-limit #f]
[sandbox-make-inspector current-inspector])
(make-evaluator '(begin (require scheme/base)))))
(call-with-trusted-sandbox-configuration
(lambda ()
(parameterize ([sandbox-output 'string]
[sandbox-error-output 'string])
(make-evaluator '(begin (require scheme/base)))))))
(define (close-eval e)
(kill-evaluator e)
"")
(define (do-plain-eval ev s catching-exns?)
(call-with-values (lambda ()
((scribble-eval-handler)

16
collects/scribblings/foreign/types.scrbl
View File

@ -20,9 +20,11 @@ along with conversion functions to and from the existing types.
[c-to-scheme (or/c #f (any/c . -> . any))])
ctype?]{
Creates a new @tech{C type} value, with the given conversions
functions. The conversion functions can be @scheme[#f] meaning that
there is no conversion for the corresponding direction. If both
Creates a new @tech{C type} value whose representation for foreign
code is the same as @scheme[type]'s. The given conversions functions
convert to and from the Scheme representation of @scheme[type]. Either
conversion function can be @scheme[#f], meaning that the conversion
for the corresponding direction is the identity function. If both
functions are @scheme[#f], @scheme[type] is returned.}
@ -338,7 +340,7 @@ values: @itemize[
the callback value will be stored in the box, overriding any value
that was in the box (making it useful for holding a single callback
value). When you know that it is no longer needed, you can
`release' the callback value by changing the box contents, or by
``release'' the callback value by changing the box contents, or by
allowing the box itself to be garbage-collected. This is can be
useful if the box is held for a dynamic extent that corresponds to
when the callback is needed; for example, you might encapsulate some
@ -400,7 +402,7 @@ used to access the actual foreign return value.
In rare cases where complete control over the input arguments is needed, the
wrapper's argument list can be specified as @scheme[args], in any form (including
a `rest' argument). Identifiers in this place are related to type labels, so
a ``rest'' argument). Identifiers in this place are related to type labels, so
if an argument is there is no need to use an expression.
For example,
@ -746,7 +748,7 @@ than the struct itself. The following works as expected:
As described above, @scheme[_list-struct]s should be used in cases where
efficiency is not an issue. We continue using @scheme[define-cstruct], first
define a type for @cpp{A} which makes it possible to use `@cpp{makeA}:
define a type for @cpp{A} which makes it possible to use @cpp{makeA}:
@schemeblock[
(define-cstruct #,(schemeidfont "_A") ([x _int] [y _byte]))
@ -785,7 +787,7 @@ We can access all values of @scheme[b] using a naive approach:
]
but this is inefficient as it allocates and copies an instance of
`@cpp{A}' on every access. Inspecting the tags @scheme[(cpointer-tag
@cpp{A} on every access. Inspecting the tags @scheme[(cpointer-tag
b)] we can see that @cpp{A}'s tag is included, so we can simply use
its accessors and mutators, as well as any function that is defined to
take an @cpp{A} pointer:

5
collects/scribblings/foreign/unexported.scrbl
View File

@ -39,8 +39,9 @@ These values can also be used as C pointer objects.}
[(ctype-c->scheme [type ctype?]) procedure?])]{
Accessors for the components of a C type object, made by
@scheme[make-ctype]. The @scheme[ctype-basetype] selector returns
@scheme[#f] for primitive types (including cstruct types).}
@scheme[make-ctype]. The @scheme[ctype-basetype] selector returns a
symbol for primitive types that names the type, a list of ctypes for
cstructs, and another ctype for user-defined ctypes.}
@defproc[(ffi-call [ptr any/c] [in-types (listof ctype?)] [out-type ctype?]

21
collects/scribblings/reference/custodians.scrbl
View File

@ -57,19 +57,19 @@ or indirectly). If @scheme[cust] is not strictly subordinate to
@defproc[(custodian-memory-accounting-available?) boolean?]{
Returns @scheme[#t] if PLT Scheme is compiled with support for
per-custodian memory accounting, @scheme[#f] otherwise.
@margin-note{Memory accounting is normally available in PLT Scheme 3m,
which is the main variant of PLT Scheme, and not normally available in
PLT Scheme CGC.}}
PLT Scheme CGC.}
Returns @scheme[#t] if PLT Scheme is compiled with support for
per-custodian memory accounting, @scheme[#f] otherwise.}
@defproc[(custodian-require-memory [limit-cust custodian?]
[need-amt exact-nonnegative-integer?]
[stop-cust custodian?]) void?]{
Registers a require check if PLT Scheme is compiled with support for
per-custodian memory accounting, otherwise the
Registers a required-memory check if PLT Scheme is compiled with
support for per-custodian memory accounting, otherwise the
@exnraise[exn:fail:unsupported].
If a check is registered, and if PLT Scheme later reaches a state after
@ -81,8 +81,8 @@ trigger some shutdown, then @scheme[stop-cust] is shut down.}
[limit-amt exact-nonnegative-integer?]
[stop-cust custodian? limit-cust]) void?]{
Registers a limit check if PLT Scheme is compiled with support for
per-custodian memory accounting, otherwise the
Registers a limited-memory check if PLT Scheme is compiled with
support for per-custodian memory accounting, otherwise the
@exnraise[exn:fail:unsupported].
If a check is registered, and if PLT Scheme later reaches a state
@ -93,7 +93,10 @@ after garbage collection (see @secref["gc-model"]) where
@margin-note{A custodian's limit is checked only after a garbage
collection, except that it may also be checked during
certain large allocations that are individually larger
than the custodian's limit.}
than the custodian's limit. A single garbage collection
may shut down multiple custodians, even if shutting down
only one of the custodians would have reduced memory use
for other custodians.}
For reliable shutdown, @scheme[limit-amt] for
@scheme[custodian-limit-memory] must be much lower than the total

10
collects/scribblings/reference/eval-model.scrbl
View File

@ -801,7 +801,9 @@ object is reachable from two custodians where neither is an ancestor
of the other, an object is arbitrarily charged to one of the other,
and the choice can change after each collection; objects reachable
from both a custodian and its descendant, however, are reliably
charged to the descendant. Reachability for per-custodian accounting
does not include weak references, references to threads managed by
non-descendant custodians, references to non-descendant custodians, or
references to custodian boxes for non-descendant custodians.
charged to the custodian and not to the descendants, unless the
custodian can reach the objects only through a descendant custodian or
a descendant's thread. Reachability for per-custodian accounting does
not include weak references, references to threads managed by other
custodians, references to other custodians, or references to custodian
boxes for other custodians.

120
collects/scribblings/reference/sandbox.scrbl
View File

@ -16,12 +16,11 @@
The @schememodname[scheme/sandbox] module provides utilities for
creating ``sandboxed'' evaluators, which are configured in a
particular way and can have restricted resources (memory and time),
filesystem access, and network access. The common use case for this
module is for a restricted sandboxed environment, so the defaults are
set up to make it safe. For other uses you will likely need to change
mane of these settings.
filesystem and network access, and much. Sandboxed evaluators can be
configured through numerous parameters --- and the defaults are set
for the common use case where sandboxes are very limited.
@defproc*[([(make-evaluator [language (or/c module-path?
@defproc*[([(make-evaluator [language (or/c module-path?
(list/c 'special symbol?)
(cons/c 'begin list?))]
[input-program any/c] ...
@ -260,9 +259,29 @@ either @scheme['time] or @scheme['memory].}
@section{Customizing Evaluators}
The evaluators that @scheme[make-evaluator] creates can be customized
via several parameters. These parameters affect newly created
evaluators; changing them has no effect on already-running evaluators.
The sandboxed evaluators that @scheme[make-evaluator] creates can be
customized via many parameters. Most of the configuration parameters
affect newly created evaluators; changing them has no effect on
already-running evaluators.
The default configuration options are set for a very restricted
sandboxed environment --- one that is safe to make publicly available.
Further customizations might be needed in case more privileges are
needed, or if you want tighter restrictions. Another useful approach
for customizing an evaluator is to begin with a relatively
unrestricted configuration and add the desired restrictions. This is
possible by the @scheme[call-with-trusted-sandbox-configuration]
function.
@defproc[(call-with-trusted-sandbox-configuration [thunk (-> any)])
any]{
Invokes the @scheme[thunk] in a context where sandbox configuration
parameters are set for minimal restrictions. More specifically, there
are no memory or time limits, and the existing existing inspectors,
security guard, exit handler, and logger are used. (Note that the I/O
ports settings are not included.)}
@defparam[sandbox-init-hook thunk (-> any)]{
@ -443,7 +462,7 @@ specifications in @scheme[sandbox-path-permissions], and it uses
@defparam[sandbox-path-permissions perms
(listof (list/c (or/c 'execute 'write 'delete 'read 'exists)
(listof (list/c (or/c 'execute 'write 'delete 'read-bytecode 'read 'exists)
(or/c byte-regexp? bytes? string? path?)))]{
A parameter that configures the behavior of the default sandbox
@ -453,9 +472,9 @@ each is an access mode and a byte-regexp for paths that are granted this
access.
The access mode symbol is one of: @scheme['execute], @scheme['write],
@scheme['delete], @scheme['read], or @scheme['exists]. These symbols are
in decreasing order: each implies access for the following modes too
(e.g., @scheme['read] allows reading or checking for existence).
@scheme['delete], @scheme['read], or @scheme['exists]. These symbols
are in decreasing order: each implies access for the following modes
too (e.g., @scheme['read] allows reading or checking for existence).
The path regexp is used to identify paths that are granted access. It
can also be given as a path (or a string or a byte string), which is
@ -463,9 +482,25 @@ can also be given as a path (or a string or a byte string), which is
to a regexp that allows the path and sub-directories; e.g.,
@scheme["/foo/bar"] applies to @scheme["/foo/bar/baz"].
An additional mode symbol, @scheme['read-bytecode], is not part of the
linear order of these modes. Specifying this mode is similar to
specifying @scheme['read], but it is not implied by any other mode.
(For example, even if you specify @scheme['write] for a certain path,
you need to also specify @scheme['read-bytecode] to grant this
permission.) The sandbox usually works in the context of a lower code
inspector (see @scheme[sandbox-make-code-inspector]) which prevents
loading of untrusted bytecode files --- the sandbox is set-up to allow
loading bytecode from files that are specified with
@scheme['read-bytecode]. This specification is given by default to
the PLT collection hierarchy (including user-specific libraries) and
to libraries that are explicitly specified in an @scheme[#:allow-read]
argument. (Note that this applies for loading bytecode files only,
under a lower code inspector it is still impossible to use protected
module bindings (see @secref["modprotect"]).)
The default value is null, but when an evaluator is created, it is
augmented by @scheme['read] permissions that make it possible to use
collection libraries (including
augmented by @scheme['read-bytecode] permissions that make it possible
to use collection libraries (including
@scheme[sandbox-override-collection-paths]). See
@scheme[make-evalautor] for more information.}
@ -490,29 +525,54 @@ appropriate error message (see
@scheme[exn:fail:sandbox-terminated-reason]).}
@defparam[sandbox-memory-limit limit (or/c exact-nonnegative-integer? #f)]{
@defparam[sandbox-memory-limit limit (or/c nonnegative-number? #f)]{
A parameter that determines the total memory limit on the sandbox.
When this limit is exceeded, the sandbox is terminated. This value is
used when the sandbox is created and the limit cannot be changed
afterwards. See @scheme[sandbox-eval-limits] for per-evaluation
limits and a description of how the two limits work together.}
A parameter that determines the total memory limit on the sandbox in
megabytes (it can hold a rational or a floating point number). When
this limit is exceeded, the sandbox is terminated. This value is used
when the sandbox is created and the limit cannot be changed
afterwards. It defaults to 30mb. See @scheme[sandbox-eval-limits]
for per-evaluation limits and a description of how the two limits work
together.
Note that (when memory accounting is enabled) memory is attributed to
the highest custodian that refers to it. This means that if you
inspect a value that sandboxed evaluation returns outside of the
sandbox, your own custodian will be charged for it. To ensure that it
is charged back to the sandbox, you should remove references to such
values when the code is done inspecting it.
This policy has an impact on how the sandbox memory limit interacts
with the the per-expression limit specified by
@scheme[sandbox-eval-limits]: values that are reachable from the
sandbox, as well as from the interaction will count against the
sandbox limit. For example, in the last interaction of this code,
@schemeblock[
(define e (make-evaluator 'scheme/base))
(e '(define a 1))
(e '(for ([i (in-range 20)]) (set! a (cons (make-bytes 500000) a))))
]
the memory blocks are allocated within the interaction limit, but
since they're chained to the defined variable, they're also reachable
from the sandbox --- so they will count against the sandbox memory
limit but not against the interaction limit (more precisely, no more
than one block counts against the interaction limit).}
@defparam[sandbox-eval-limits limits
(or/c (list/c (or/c exact-nonnegative-integer? #f)
(or/c exact-nonnegative-integer? #f))
(or/c (list/c (or/c nonnegative-number? #f)
(or/c nonnegative-number? #f))
#f)]{
A parameter that determines the default limits on @italic{each} use of
a @scheme[make-evaluator] function, including the initial evaluation
of the input program. Its value should be a list of two numbers;
where the first is a timeout value in seconds, and the second is a
memory limit in megabytes. Either one can be @scheme[#f] for
disabling the corresponding limit; alternately, the parameter can be
set to @scheme[#f] to disable all per-evaluation limits (useful in
case more limit kinds are available in future versions). The default
is @scheme[(list 30 20)].
memory limit in megabytes (note that they don't have to be integers).
Either one can be @scheme[#f] for disabling the corresponding limit;
alternately, the parameter can be set to @scheme[#f] to disable all
per-evaluation limits (useful in case more limit kinds are available
in future versions). The default is @scheme[(list 30 20)].
Note that these limits apply to the creation of the sandbox
environment too --- even @scheme[(make-evaluator 'scheme/base)] can
@ -582,7 +642,11 @@ an evaluator, and the default parameter value is
A parameter that determines the procedure used to create the code
inspector for sandboxed evaluation. The procedure is called when
initializing an evaluator, and the default parameter value is
@scheme[make-inspector].}
@scheme[make-inspector]. The @scheme[current-load/use-compiled]
handler is setup to still allow loading of bytecode files under the
original code inspector when @scheme[sandbox-path-permissions] allows
it through a @scheme['read-bytecode] mode symbol, to make it possible
to load libraries.}
@defparam[sandbox-make-logger make (-> logger?)]{

4
collects/scribblings/reference/security-guards.scrbl
View File

@ -37,8 +37,8 @@ host platform.
(or/c (integer-in 1 65535) #f)
(or/c 'server 'client)
. -> . any)]
[link (or/c (symbol? path? path? . -> . any) #f)
#f])
[link-guard (or/c (symbol? path? path? . -> . any) #f)
#f])
security-guard?]{
Creates a new security guard as child of @scheme[parent].

2
collects/string-constants/english-string-constants.ss
View File

@ -862,7 +862,7 @@ please adhere to these guidelines:
(force-quit-menu-item-help-string "Uses custodian-shutdown-all to abort the current evaluation")
(limit-memory-menu-item-label "Limit Memory...")
(limit-memory-msg-1 "The limit will take effect the next time the program")
(limit-memory-msg-2 "is Run, and it must be at least 100 megabytes.")
(limit-memory-msg-2 "is Run, and it must be at least one megabyte.")
(limit-memory-unlimited "Unlimited")
(limit-memory-limited "Limited")
(limit-memory-megabytes "Megabytes")

2
collects/string-constants/french-string-constants.ss
View File

@ -859,7 +859,7 @@
(force-quit-menu-item-help-string "Utilise custodian-shutdown-all pour terminer toute l'évaluation courante")
(limit-memory-menu-item-label "Limiter la mémoire...")
(limit-memory-msg-1 "La limite prendra effet à la prochaine exécution du programme.")
(limit-memory-msg-2 "Elle doit être d'au moins 100 megaoctets.")
(limit-memory-msg-2 "Elle doit être d'au moins 1 megaoctet.")
(limit-memory-unlimited "Illimitée")
(limit-memory-limited "Limitée")
(limit-memory-megabytes "Megaoctets")

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

@ -763,7 +763,7 @@
(force-quit-menu-item-help-string "Benutzt custodian-shutdown-all, um die Auswertung abzubrechen")
(limit-memory-menu-item-label "Speicherverbrauch einschränken...")
(limit-memory-msg-1 "Das Limit wird beim nächsten Programmstart aktiv")
(limit-memory-msg-2 "und muß mindestens 100 Megabytes betragen.")
(limit-memory-msg-2 "und muß mindestens 1 Megabyte betragen.")
(limit-memory-unlimited "nicht einschränken")
(limit-memory-limited "einschränken")
(limit-memory-megabytes "Megabytes")

2
collects/string-constants/japanese-string-constants.ss
View File

@ -805,7 +805,7 @@ please adhere to these guidelines:
(kill-menu-item-help-string "現在の評価を強制終了します")
(limit-memory-menu-item-label "メモリを制限する...")
(limit-memory-msg-1 "ここで指定したメモリ制限値は、プログラムを次に実行するときに有効になります。")
(limit-memory-msg-2 "制限値は 100MB 以上にしてください。")
(limit-memory-msg-2 "制限値は 1MB 以上にしてください。")
(limit-memory-unlimited "制限しない")
(limit-memory-limited "制限する")
(limit-memory-megabytes "MB")

2
collects/string-constants/simplified-chinese-string-constants.ss
View File

@ -780,7 +780,7 @@
(force-quit-menu-item-help-string "使用custodian-shutdown-all退出当前计算")
(limit-memory-menu-item-label "限制内存使用...")
(limit-memory-msg-1 "内存限制会在下一次运行")
(limit-memory-msg-2 "时生效。内存限制最低值为100megabytes.")
(limit-memory-msg-2 "时生效。内存限制最低值为1megabyte.")
(limit-memory-unlimited "无限制")
(limit-memory-limited "限制")
(limit-memory-megabytes "Megabytes")

2
collects/string-constants/traditional-chinese-string-constants.ss
View File

@ -779,7 +779,7 @@
(force-quit-menu-item-help-string "使用custodian-shutdown-all退出当前计算")
(limit-memory-menu-item-label "限制内存使用...")
(limit-memory-msg-1 "内存限制会在下一次运行")
(limit-memory-msg-2 "时生效。内存限制最低值为100megabytes.")
(limit-memory-msg-2 "时生效。内存限制最低值为1megabyte.")
(limit-memory-unlimited "无限制")
(limit-memory-limited "限制")
(limit-memory-megabytes "Megabytes")

189
collects/tests/mzscheme/sandbox.ss
View File

@ -148,11 +148,11 @@
=err> "out of time"
(when (custodian-memory-accounting-available?)
(t --top--
(set! ev (parameterize ([sandbox-eval-limits '(0.25 2)])
(set! ev (parameterize ([sandbox-eval-limits '(2 2)])
(make-evaluator 'scheme/base
'(define a (for/list ([i (in-range 10)])
(collect-garbage)
(make-string 1000))))))
(make-bytes 500000))))))
=err> "out of memory"))
;; i/o
@ -275,59 +275,94 @@
;; limited FS access, allowed for requires
--top--
(let* ([tmp (find-system-path 'temp-dir)]
[schemelib (path->string (collection-path "scheme"))]
[list-lib (path->string (build-path schemelib "list.ss"))]
[test-lib (path->string (build-path tmp "sandbox-test.ss"))])
(t --top--
(set! ev (make-evaluator 'scheme/base))
--eval--
;; reading from collects is allowed
(list (directory-list ,schemelib))
(file-exists? ,list-lib) => #t
(input-port? (open-input-file ,list-lib)) => #t
;; writing is forbidden
(open-output-file ,list-lib) =err> "`write' access denied"
;; reading from other places is forbidden
(directory-list ,tmp) =err> "`read' access denied"
;; no network too
(require scheme/tcp)
(tcp-listen 12345) =err> "network access denied"
--top--
;; reading from a specified require is fine
(with-output-to-file test-lib
(lambda ()
(printf "~s\n" '(module sandbox-test scheme/base
(define x 123) (provide x))))
#:exists 'replace)
(set! ev (make-evaluator 'scheme/base #:requires `(,test-lib)))
--eval--
x => 123
(length (with-input-from-file ,test-lib read)) => 5
;; the directory is still not kosher
(directory-list ,tmp) =err> "`read' access denied"
--top--
;; should work also for module evaluators
;; --> NO! Shouldn't make user code require whatever it wants
;; (set! ev (make-evaluator `(module foo scheme/base
;; (require (file ,test-lib)))))
;; --eval--
;; x => 123
;; (length (with-input-from-file ,test-lib read)) => 5
;; ;; the directory is still not kosher
;; (directory-list tmp) =err> "file access denied"
--top--
;; explicitly allow access to tmp
(set! ev (parameterize ([sandbox-path-permissions
`((read ,tmp)
,@(sandbox-path-permissions))])
(make-evaluator 'scheme/base)))
--eval--
(length (with-input-from-file ,test-lib read)) => 5
(list? (directory-list ,tmp))
(open-output-file ,(build-path tmp "blah")) =err> "access denied"
(delete-directory ,(build-path tmp "blah")) =err> "access denied")
(delete-file test-lib))
(let* ([tmp (make-temporary-file "sandboxtest~a" 'directory)]
[strpath (lambda xs (path->string (apply build-path xs)))]
[schemelib (strpath (collection-path "scheme"))]
[list-lib (strpath schemelib "list.ss")]
[list-zo (strpath schemelib "compiled" "list_ss.zo")]
[test-lib (strpath tmp "sandbox-test.ss")]
[test-zo (strpath tmp "compiled" "sandbox-test_ss.zo")]
[test2-lib (strpath tmp "sandbox-test2.ss")]
[test2-zo (strpath tmp "compiled" "sandbox-test2_ss.zo")])
(t --top--
(set! ev (make-evaluator 'scheme/base))
--eval--
;; reading from collects is allowed
(list? (directory-list ,schemelib))
(file-exists? ,list-lib) => #t
(input-port? (open-input-file ,list-lib)) => #t
;; writing is forbidden
(open-output-file ,list-lib) =err> "`write' access denied"
;; reading from other places is forbidden
(directory-list ,tmp) =err> "`read' access denied"
;; no network too
(require scheme/tcp)
(tcp-listen 12345) =err> "network access denied"
--top--
;; reading from a specified require is fine
(with-output-to-file test-lib
(lambda ()
(printf "~s\n" '(module sandbox-test scheme/base
(define x 123) (provide x)))))
(set! ev (make-evaluator 'scheme/base #:requires `(,test-lib)))
--eval--
x => 123
(length (with-input-from-file ,test-lib read)) => 5
;; the directory is still not kosher
(directory-list ,tmp) =err> "`read' access denied"
--top--
;; should work also for module evaluators
;; --> NO! Shouldn't make user code require whatever it wants
;; (set! ev (make-evaluator `(module foo scheme/base
;; (require (file ,test-lib)))))
;; --eval--
;; x => 123
;; (length (with-input-from-file ,test-lib read)) => 5
;; ;; the directory is still not kosher
;; (directory-list tmp) =err> "file access denied"
--top--
;; explicitly allow access to tmp, and write access to a single file
(make-directory (build-path tmp "compiled"))
(set! ev (parameterize ([sandbox-path-permissions
`((read ,tmp)
(write ,test-zo)
,@(sandbox-path-permissions))])
(make-evaluator 'scheme/base)))
--eval--
(length (with-input-from-file ,test-lib read)) => 5
(list? (directory-list ,tmp))
(open-output-file ,(build-path tmp "blah")) =err> "access denied"
(delete-directory ,(build-path tmp "blah")) =err> "access denied"
(list? (directory-list ,schemelib))
;; we can read/write/delete list-zo, but we can't load bytecode from
;; it due to the code inspector
(copy-file ,list-zo ,test-zo) => (void)
(copy-file ,test-zo ,list-zo) =err> "access denied"
(load/use-compiled ,test-lib) => (void)
(require 'list) =err> "access from an uncertified context"
(delete-file ,test-zo) => (void)
(delete-file ,test-lib) =err> "`delete' access denied"
--top--
;; a more explicit test of bytcode loading, allowing rw access to the
;; complete tmp directory, but read-bytecode only for test2-lib
(set! ev (parameterize ([sandbox-path-permissions
`((write ,tmp)
(read-bytecode ,test2-lib)
,@(sandbox-path-permissions))])
(make-evaluator 'scheme/base)))
--eval--
(define (cp from to)
(when (file-exists? to) (delete-file to))
(copy-file from to))
(cp ,list-lib ,test-lib) (cp ,list-zo ,test-zo)
(cp ,list-lib ,test2-lib) (cp ,list-zo ,test2-zo)
;; bytecode from test-lib is bad, even when we can read/write to it
(load/use-compiled ,test-zo)
(require 'list) =err> "access from an uncertified context"
;; bytecode from test2-lib is explicitly allowed
(load/use-compiled ,test2-lib)
(require 'list) => (void))
((dynamic-require 'scheme/file 'delete-directory/files) tmp))
;; languages and requires
--top--
@ -388,30 +423,17 @@
--top--
(set! ev (parameterize ([sandbox-output 'bytes]
[sandbox-error-output current-output-port]
[sandbox-memory-limit 5]
[sandbox-eval-limits '(0.25 1/2)])
[sandbox-memory-limit 2]
[sandbox-eval-limits '(0.25 1)])
(make-evaluator 'scheme/base)))
;; GCing is needed to allow these to happen
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
--eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000
;; GCing is needed to allow these to happen (note: the memory limit is very
;; tight here, this test usually fails if the sandbox library is not
;; compiled)
(let ([t (lambda ()
(t --eval-- (display (make-bytes 400000 65)) (collect-garbage)
--top-- (bytes-length (get-output ev)) => 400000))])
;; can go arbitrarily high here
(for ([i (in-range 20)]) (t)))
;; test that killing the custodian works fine
;; first try it without limits (limits imply a nested thread/custodian)
@ -466,9 +488,14 @@
--eval--
(define a '())
(define b 1)
(for ([i (in-range 20)])
(set! a (cons (make-bytes 500000) a))
(collect-garbage))
(length
(for/fold ([v null]) ([i (in-range 20)])
;; increases size of sandbox: it's reachable from it (outside of
;; this evaluation) because `a' is defined there
(set! a (cons (make-bytes 500000) a))
(collect-garbage)
;; increases size of the current evaluation
(cons (make-bytes 500000) v)))
=err> "out of memory"
b => 1))

18
collects/tests/mzscheme/testing.ss
View File

@ -77,17 +77,13 @@ transcript.
(define number-of-exn-tests 0)
(define (load-in-sandbox file)
(let ([e (parameterize ([(dynamic-require 'scheme/sandbox 'sandbox-security-guard)
(current-security-guard)]
[(dynamic-require 'scheme/sandbox 'sandbox-input)
current-input-port]
[(dynamic-require 'scheme/sandbox 'sandbox-output)
current-output-port]
[(dynamic-require 'scheme/sandbox 'sandbox-error-output)
current-error-port]
[(dynamic-require 'scheme/sandbox 'sandbox-eval-limits)
#f])
((dynamic-require 'scheme/sandbox 'make-evaluator) '(begin) #:requires (list 'scheme)))])
(define-syntax-rule (S id) (dynamic-require 'scheme/sandbox 'id))
(let ([e ((S call-with-trusted-sandbox-configuration)
(parameterize ([(S sandbox-input) current-input-port]
[(S sandbox-output) current-output-port]
[(S sandbox-error-output) current-error-port]
[(S sandbox-memory-limit) 100]) ; 100mb per box
((S make-evaluator) '(begin) #:requires (list 'scheme))))])
(e `(load-relative "testing.ss"))
(e `(define real-error-port (quote ,real-error-port)))
(e `(define Section-prefix ,Section-prefix))

3
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 4.1.3.6
Memory accounting changed to bias charges to parent instead of children
Version 4.1.3.3
Added compile-context-preservation-enabled
Added exception-backtrace support for x86_84+JIT

109
src/foreign/foreign.c
View File

@ -810,9 +810,16 @@ typedef union _ForeignAny {
/* Type objects */
/* This struct is used for both user types and primitive types (including
* struct types). If it is a primitive type then basetype will be NULL, and
* struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. */
* integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
* type by the basetype field.)
*/
/* ctype structure definition */
static Scheme_Type ctype_tag;
typedef struct ctype_struct {
@ -849,8 +856,8 @@ END_XFORM_SKIP;
#endif
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x)))
#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x)))
#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
@ -861,12 +868,9 @@ END_XFORM_SKIP;
#define MYNAME "ctype-basetype"
static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
{
Scheme_Object *base;
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
base = CTYPE_BASETYPE(argv[0]);
if (NULL == base) return scheme_false;
else return base;
return CTYPE_BASETYPE(argv[0]);
}
#undef MYNAME
@ -1046,7 +1050,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
type->so.type = ctype_tag;
type->basetype = (NULL);
type->basetype = (argv[0]);
type->scheme_to_c = ((Scheme_Object*)libffi_type);
type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
@ -1166,12 +1170,11 @@ END_XFORM_SKIP;
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc)
{
Scheme_Object *res, *base;
Scheme_Object *res;
if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
base = CTYPE_BASETYPE(type);
if (base != NULL) {
res = C2SCHEME(base, src, delta, args_loc);
if (CTYPE_USERP(type)) {
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res;
else
@ -2347,7 +2350,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
offset = 0;
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
&offset, 0);
if (p != NULL) {
if ((p != NULL) || offset) {
avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */
} else {
@ -2370,7 +2373,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* We finished with all possible mallocs, clear up the avalues and offsets
* mess */
for (i=0; i<nargs; i++) {
if (avalues[i] == NULL) /* if this was a non-pointer... */
if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */
@ -2632,6 +2635,7 @@ void scheme_init_foreign(Scheme_Env *env)
{
Scheme_Env *menv;
ctype_struct *t;
Scheme_Object *s;
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
ffi_lib_tag = scheme_make_type("<ffi-lib>");
ffi_obj_tag = scheme_make_type("<ffi-obj>");
@ -2749,153 +2753,178 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
scheme_add_global("ffi-callback",
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv);
s = scheme_intern_symbol("void");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_void);
scheme_add_global("_void", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
scheme_add_global("_int8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
scheme_add_global("_uint8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
scheme_add_global("_int16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
scheme_add_global("_uint16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
scheme_add_global("_int32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
scheme_add_global("_uint32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
scheme_add_global("_int64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
scheme_add_global("_uint64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint);
scheme_add_global("_fixint", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("ufixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint);
scheme_add_global("_ufixint", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixnum");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
scheme_add_global("_fixnum", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("ufixnum");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
scheme_add_global("_ufixnum", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("float");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
scheme_add_global("_float", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
scheme_add_global("_double", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double*");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS);
scheme_add_global("_double*", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bool");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool);
scheme_add_global("_bool", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/ucs-4");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bytes");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
scheme_add_global("_bytes", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("path");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
scheme_add_global("_path", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("symbol");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol);
scheme_add_global("_symbol", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("pointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
scheme_add_global("_pointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("scheme");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
scheme_add_global("_scheme", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
scheme_add_global("_fpointer", (Scheme_Object*)t, menv);

59
src/foreign/foreign.ssc
View File

@ -10,6 +10,8 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0"
** to make changes, edit that file and
** run it to generate an updated version
** of this file.
** NOTE: This is no longer true, foreign.ssc needs to be updated to work with
** the scribble/text preprocessor instead.
********************************************/
{:(load "ssc-utils.ss"):}
@ -445,7 +447,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
(define *type-counter* 0)
(define (describe-type stype cname ftype ctype pred s->c c->s offset)
(define (describe-type type stype cname ftype ctype pred s->c c->s offset)
(set! *type-counter* (add1 *type-counter*))
(~ "#define FOREIGN_"cname" ("*type-counter*")" \\
"/* Type Name: "stype (and (not (equal? cname stype))
@ -466,7 +468,10 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
" * C->Scheme: "(cond [(not c->s) "-none-"]
[(procedure? c->s) (c->s "<C>")]
[else (list c->s"(<C>)")]) \\
" */" \\))
" */" \\
;; no need for these, at least for now:
;; "static Scheme_Object *"cname"_sym;"\\
))
(define (make-ctype type args)
(define (prop p . default)
@ -491,7 +496,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[s->c (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))]
[c->s (prop 'c->s)]
[offset (prop 'offset #f)])
(describe-type stype cname ftype ctype pred s->c c->s offset)
(describe-type type stype cname ftype ctype pred s->c c->s offset)
`(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset))))
@ -726,17 +731,24 @@ typedef union _ForeignAny {
/* Type objects */
/* This struct is used for both user types and primitive types (including
* struct types). If it is a primitive type then basetype will be NULL, and
* struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. */
* integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
* type by the basetype field.)
*/
{:(cdefstruct ctype
(basetype "Scheme_Object*")
(scheme_to_c "Scheme_Object*")
(c_to_scheme "Scheme_Object*")):}
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x)))
#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x)))
#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
@ -745,12 +757,9 @@ typedef union _ForeignAny {
/* Returns #f for primitive types. */
{:(cdefine ctype-basetype 1):}
{
Scheme_Object *base;
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
base = CTYPE_BASETYPE(argv[0]);
if (NULL == base) return scheme_false;
else return base;
return CTYPE_BASETYPE(argv[0]);
}
{:(cdefine ctype-scheme->c 1):}
@ -892,7 +901,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
dummy = &libffi_type;
if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
{:(cmake-object "type" ctype "NULL"
{:(cmake-object "type" ctype "argv[0]"
"(Scheme_Object*)libffi_type"
"(Scheme_Object*)FOREIGN_struct"):}
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
@ -974,12 +983,11 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc)
{
Scheme_Object *res, *base;
Scheme_Object *res;
if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
base = CTYPE_BASETYPE(type);
if (base != NULL) {
res = C2SCHEME(base, src, delta, args_loc);
if (CTYPE_USERP(type)) {
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res;
else
@ -1677,6 +1685,9 @@ static Scheme_Object *do_memop(const char *who, int mode,
len, 0);
}
/* *** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors. */
/* internal: apply Scheme finalizer */
void do_scm_finalizer(void *p, void *finalizer)
{
@ -1707,9 +1718,6 @@ void do_ptr_finalizer(void *p, void *finalizer)
/* (Only needed in cases where pointer aliases might be created.) */
/*
*** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors.
{:"(defsymbols pointer)":}
{:"(cdefine register-finalizer 2 3)":}
{
@ -1789,7 +1797,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
offset = 0;
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
&offset, 0);
if (p != NULL) {
if ((p != NULL) || offset) {
avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */
} else {
@ -1812,7 +1820,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* We finished with all possible mallocs, clear up the avalues and offsets
* mess */
for (i=0; i<nargs; i++) {
if (avalues[i] == NULL) /* if this was a non-pointer... */
if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */
@ -1961,7 +1969,7 @@ typedef struct closure_and_cif_struct {
void free_cl_cif_args(void *ignored, void *p)
{
/*
scheme_warning("Releaseing cl+cif+args %V %V (%d)",
scheme_warning("Releasing cl+cif+args %V %V (%d)",
ignored,
(((closure_and_cif*)p)->data),
SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
@ -2066,6 +2074,7 @@ void scheme_init_foreign(Scheme_Env *env)
{
Scheme_Env *menv;
ctype_struct *t;
Scheme_Object *s;
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
{:(for-each (lambda (x)
(~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");"))
@ -2090,7 +2099,11 @@ void scheme_init_foreign(Scheme_Env *env)
(cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);"))
(reverse! cfunctions))
(for-each-type
(cmake-object "t" ctype "NULL"
;; no need for these, at least for now:
;; (~ "MZ_REGISTER_STATIC("cname"_sym);" \\
;; cname"_sym = scheme_intern_symbol(\""stype"\");")
(~ "s = scheme_intern_symbol(\""stype"\");")
(cmake-object "t" ctype "s"
(list "(Scheme_Object*)(void*)(&ffi_type_"ftype")")
(list "(Scheme_Object*)FOREIGN_"cname))
(~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):}

2
src/mred/Makefile.in
View File

@ -351,6 +351,7 @@ install-wx_mac-cgc:
$(ICP) -r PLT_MrEd.framework/Versions/$(FWVERSION)/Resources $(MRFWDIR)/Versions/$(FWVERSION)/Resources
/usr/bin/install_name_tool -change "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)/PLT_MrEd" "@FRAMEWORK_PREFIX@PLT_MrEd.framework/Versions/$(FWVERSION)/PLT_MrEd" "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@"
$(MZSCHEME) -cu "$(srcdir)/../mzscheme/collects-path.ss" "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@" ../../../collects
/usr/bin/strip -S "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@"
install-wx_mac-cgc-final:
ln -s Versions/$(FWVERSION)/PLT_MrEd $(MRFWDIR)/
@ -364,6 +365,7 @@ install-wx_mac-3m:
$(ICP) -r "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources" "$(MRFWDIR)/Versions/$(FWVERSION)_3m/Resources"
/usr/bin/install_name_tool -change "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "@FRAMEWORK_PREFIX@PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@"
$(MZSCHEME) -cu "$(srcdir)/../mzscheme/collects-path.ss" "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@" "../../../collects"
/usr/bin/strip -S "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@"
install-wx_mac-3m-final:
ln -s Versions/$(FWVERSION)_3m/PLT_MrEd $(MRFWDIR)/

3
src/mzscheme/Makefile.in
View File

@ -271,6 +271,7 @@ unix-install:
cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@CGC_INSTALLED@"
cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@MMM_INSTALLED@"
cd ..; cp mzscheme/starter "$(DESTDIR)$(libpltdir)/starter"
cd ..; strip -S "$(DESTDIR)$(libpltdir)/starter"
cd ..; echo 'CC=@CC@' > "$(BUILDINFO)"
cd ..; echo 'CFLAGS=@CFLAGS@ @PREFLAGS@ @COMPFLAGS@' >> "$(BUILDINFO)"
cd ..; echo 'OPTIONS=@OPTIONS@' >> "$(BUILDINFO)"
@ -316,6 +317,7 @@ osx-install-cgc:
mkdir -p "$(MZFWDIR)/Versions/$(FWVERSION)"
cp $(MZFW) $(MZFWDIR)/Versions/$(FWVERSION)/
/usr/bin/install_name_tool -change "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)/PLT_MzScheme" "@FRAMEWORK_PREFIX@PLT_MzScheme.framework/Versions/$(FWVERSION)/PLT_MzScheme" "$(bindir)/mzscheme@CGC_INSTALLED@"
/usr/bin/strip -S "$(bindir)/mzscheme@CGC_INSTALLED@"
osx-install-cgc-final:
$(MAKE) unix-install-cgc-final
@ -326,6 +328,7 @@ osx-install-3m:
mkdir -p "$(MZFWDIR)/Versions/$(FWVERSION)_3m"
cp $(MZFWMMM) $(MZFWDIR)/Versions/$(FWVERSION)_3m/
/usr/bin/install_name_tool -change "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "@FRAMEWORK_PREFIX@PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "$(bindir)/mzscheme@MMM_INSTALLED@"
/usr/bin/strip -S "$(bindir)/mzscheme@MMM_INSTALLED@"
osx-install-3m-final:
$(MAKE) unix-install-3m-final

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

@ -312,7 +312,7 @@ main.@LTO@: $(XSRCDIR)/main.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/main.c -o main.@LTO@
gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/gc2.h \
$(srcdir)/newgc.h $(srcdir)/blame_the_child.c \
$(srcdir)/newgc.h $(srcdir)/mem_account.c \
$(srcdir)/sighand.c \
$(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\
$(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \

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

@ -371,6 +371,13 @@ GC2_EXTERN void GC_fixup_variable_stack(void **var_stack,
The `stack_mem' argument indicates the start of the allocated memory
that contains `var_stack'. It is used for backtraces. */
GC2_EXTERN int GC_merely_accounting();
/*
Can be called by a mark or fixup traversal proc to determine whether
the traversal is merely for accounting, in which case some marking
can be skipped if the corresponding data should be charged to a
different object. */
GC2_EXTERN void GC_write_barrier(void *p);
/*
Explicit write barrier to ensure that a write-barrier signal is not

15
src/mzscheme/gc2/blame_the_child.c → src/mzscheme/gc2/mem_account.c
View File

@ -1,11 +1,11 @@
/*****************************************************************************/
/* blame-the-child accounting */
/* memory accounting */
/*****************************************************************************/
#ifdef NEWGC_BTC_ACCOUNT
#include "../src/schpriv.h"
/* BTC_ prefixed functions are called by newgc.c */
/* btc_ prefixed functions are internal to blame_the_child.c */
/* btc_ prefixed functions are internal to mem_account.c */
static const int btc_redirect_thread = 511;
static const int btc_redirect_custodian = 510;
@ -430,13 +430,12 @@ static void BTC_do_accounting(NewGC *gc)
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);
box = cur->global_next;
/* start with root: */
while (cur->parent && SCHEME_PTR1_VAL(cur->parent)) {
cur = SCHEME_PTR1_VAL(cur->parent);
}
/* walk backwards for the order we want */
/* walk forward for the order we want (blame parents instead of children) */
while(cur) {
int owner = custodian_to_owner_set(gc, cur);
@ -448,7 +447,7 @@ static void BTC_do_accounting(NewGC *gc)
GCDEBUG((DEBUGOUTF, "Propagating accounting marks\n"));
propagate_accounting_marks(gc);
box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
box = cur->global_next; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
}
gc->in_unsafe_allocation_mode = 0;

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

@ -93,7 +93,7 @@ inline static int is_master_gc(NewGC *gc) {
/* particular collector you want. */
/*****************************************************************************/
/* This turns on blame-the-child automatic memory accounting */
/* This turns on automatic memory accounting */
/* #define NEWGC_BTC_ACCOUNT */
/* #undef NEWGC_BTC_ACCOUNT */
@ -1365,11 +1365,11 @@ inline static void reset_pointer_stack(void)
}
/*****************************************************************************/
/* BLAME THE CHILD */
/* MEMORY ACCOUNTING */
/*****************************************************************************/
#ifdef NEWGC_BTC_ACCOUNT
# include "blame_the_child.c"
# include "mem_account.c"
#else
# define clean_up_thread_list() /* */
#endif
@ -1404,6 +1404,12 @@ void GC_register_new_thread(void *t, void *c)
#endif
}
int GC_merely_accounting()
{
NewGC *gc = GC_get_GC();
return gc->doing_memory_accounting;
}
/*****************************************************************************/
/* administration / initialization */
/*****************************************************************************/

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

@ -923,8 +923,10 @@ static int cont_proc_MARK(void *p) {
MARK_cjs(&c->cjs);
MARK_stack_state(&c->ss);
gcMARK(c->barrier_prompt);
gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
if (!GC_merely_accounting()) {
gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
}
gcMARK(c->prompt_id);
gcMARK(c->prompt_buf);
@ -961,8 +963,10 @@ static int cont_proc_FIXUP(void *p) {
FIXUP_cjs(&c->cjs);
FIXUP_stack_state(&c->ss);
gcFIXUP(c->barrier_prompt);
gcFIXUP(c->runstack_start);
gcFIXUP(c->runstack_saved);
if (!GC_merely_accounting()) {
gcFIXUP(c->runstack_start);
gcFIXUP(c->runstack_saved);
}
gcFIXUP(c->prompt_id);
gcFIXUP(c->prompt_buf);
@ -1600,12 +1604,16 @@ static int thread_val_MARK(void *p) {
gcMARK(pr->init_config);
gcMARK(pr->init_break_cell);
{
if (!pr->runstack_owner
|| !GC_merely_accounting()
|| (*pr->runstack_owner == pr)) {
Scheme_Object **rs = pr->runstack_start;
gcMARK( pr->runstack_start);
pr->runstack = pr->runstack_start + (pr->runstack - rs);
if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
pr->runstack = pr->runstack_start + (pr->runstack - rs);
gcMARK(pr->runstack_saved);
}
gcMARK(pr->runstack_saved);
gcMARK(pr->runstack_owner);
gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
@ -1706,12 +1714,16 @@ static int thread_val_FIXUP(void *p) {
gcFIXUP(pr->init_config);
gcFIXUP(pr->init_break_cell);
{
if (!pr->runstack_owner
|| !GC_merely_accounting()
|| (*pr->runstack_owner == pr)) {
Scheme_Object **rs = pr->runstack_start;
gcFIXUP_TYPED_NOW(Scheme_Object **, pr->runstack_start);
pr->runstack = pr->runstack_start + (pr->runstack - rs);
if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
pr->runstack = pr->runstack_start + (pr->runstack - rs);
gcFIXUP(pr->runstack_saved);
}
gcFIXUP(pr->runstack_saved);
gcFIXUP(pr->runstack_owner);
gcFIXUP(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
@ -1858,7 +1870,8 @@ static int prompt_val_SIZE(void *p) {
static int prompt_val_MARK(void *p) {
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcMARK(pr->boundary_overflow_id);
gcMARK(pr->runstack_boundary_start);
if (!GC_merely_accounting())
gcMARK(pr->runstack_boundary_start);
gcMARK(pr->tag);
gcMARK(pr->id);
return
@ -1868,7 +1881,8 @@ static int prompt_val_MARK(void *p) {
static int prompt_val_FIXUP(void *p) {
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcFIXUP(pr->boundary_overflow_id);
gcFIXUP(pr->runstack_boundary_start);
if (!GC_merely_accounting())
gcFIXUP(pr->runstack_boundary_start);
gcFIXUP(pr->tag);
gcFIXUP(pr->id);
return

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

@ -355,8 +355,10 @@ cont_proc {
MARK_cjs(&c->cjs);
MARK_stack_state(&c->ss);
gcMARK(c->barrier_prompt);
gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
if (!GC_merely_accounting()) {
gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
}
gcMARK(c->prompt_id);
gcMARK(c->prompt_buf);
@ -615,12 +617,16 @@ thread_val {
gcMARK(pr->init_config);
gcMARK(pr->init_break_cell);
{
if (!pr->runstack_owner
|| !GC_merely_accounting()
|| (*pr->runstack_owner == pr)) {
Scheme_Object **rs = pr->runstack_start;
gcFIXUP_TYPED_NOW(Scheme_Object **, pr->runstack_start);
pr->runstack = pr->runstack_start + (pr->runstack - rs);
if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
pr->runstack = pr->runstack_start + (pr->runstack - rs);
gcMARK(pr->runstack_saved);
}
gcMARK(pr->runstack_saved);
gcMARK(pr->runstack_owner);
gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
@ -738,7 +744,8 @@ prompt_val {
mark:
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcMARK(pr->boundary_overflow_id);
gcMARK(pr->runstack_boundary_start);
if (!GC_merely_accounting())
gcMARK(pr->runstack_boundary_start);
gcMARK(pr->tag);
gcMARK(pr->id);
size:

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

@ -1509,6 +1509,7 @@ static void print_tagged_value(const char *prefix,
void *v, int xtagged, unsigned long diff, int max_w,
const char *suffix)
{
char buffer[256];
char *type, *sep, diffstr[30];
long len;
@ -1520,7 +1521,6 @@ static void print_tagged_value(const char *prefix,
type = scheme_write_to_string_w_max((Scheme_Object *)v, &len, max_w);
if (!scheme_strncmp(type, "#<thread", 8)
&& ((type[8] == '>') || (type[8] == ':'))) {
char buffer[256];
char *run, *sus, *kill, *clean, *deq, *all, *t2;
int state = ((Scheme_Thread *)v)->running, len2;
@ -1541,7 +1541,6 @@ static void print_tagged_value(const char *prefix,
len += len2;
type = t2;
} else if (!scheme_strncmp(type, "#<continuation>", 15)) {
char buffer[256];
char *t2;
int len2;
@ -1561,8 +1560,20 @@ static void print_tagged_value(const char *prefix,
memcpy(t2 + len, buffer, len2 + 1);
len += len2;
type = t2;
} else if (!scheme_strncmp(type, "#<custodian>", 13)) {
char *t2;
int len2;
sprintf(buffer, "[%d]",
((Scheme_Custodian *)v)->elems);
len2 = strlen(buffer);
t2 = (char *)scheme_malloc_atomic(len + len2 + 1);
memcpy(t2, type, len);
memcpy(t2 + len, buffer, len2 + 1);
len += len2;
type = t2;
} else if (!scheme_strncmp(type, "#<namespace", 11)) {
char buffer[256];
char *t2;
int len2;
@ -1596,7 +1607,6 @@ static void print_tagged_value(const char *prefix,
type = t2;
} else if (!scheme_strncmp(type, "#<hash-table>", 13)
|| !scheme_strncmp(type, "#<hash-table:", 13)) {
char buffer[256];
char *t2;
int len2;
int htype, size, count;

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

@ -424,8 +424,8 @@ extern int scheme_overflow_count;
struct Scheme_Custodian {
Scheme_Object so;
char shut_down, has_limit;
int count, alloc;
char shut_down, has_limit, recorded;
int count, alloc, elems;
Scheme_Object ***boxes;
Scheme_Custodian_Reference **mrefs;
Scheme_Close_Custodian_Client **closers;

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

@ -900,6 +900,28 @@ static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[])
/* custodians */
/*========================================================================*/
static void adjust_limit_table(Scheme_Custodian *c)
{
/* If a custodian has a limit and any object or children, then it
must not be collected and merged with its parent. To prevent
collection, we register the custodian in the `limite_custodians'
table. */
if (c->has_limit) {
if (c->elems || CUSTODIAN_FAM(c->children)) {
if (!c->recorded) {
c->recorded = 1;
if (!limited_custodians)
limited_custodians = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(limited_custodians, (Scheme_Object *)c, scheme_true);
}
} else if (c->recorded) {
c->recorded = 0;
if (limited_custodians)
scheme_hash_set(limited_custodians, (Scheme_Object *)c, NULL);
}
}
}
static Scheme_Object *custodian_require_mem(int argc, Scheme_Object *args[])
{
long lim;
@ -975,13 +997,11 @@ static Scheme_Object *custodian_limit_mem(int argc, Scheme_Object *args[])
}
}
if (!limited_custodians)
limited_custodians = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(limited_custodians, args[0], scheme_true);
((Scheme_Custodian *)args[0])->has_limit = 1;
adjust_limit_table((Scheme_Custodian *)args[0]);
if (argc > 2) {
scheme_hash_set(limited_custodians, args[2], scheme_true);
((Scheme_Custodian *)args[2])->has_limit = 1;
adjust_limit_table((Scheme_Custodian *)args[2]);
}
#ifdef NEWGC_BTC_ACCOUNT
@ -1075,6 +1095,9 @@ static void add_managed_box(Scheme_Custodian *m,
m->data[i] = data;
m->mrefs[i] = mref;
m->elems++;
adjust_limit_table(m);
return;
}
}
@ -1086,6 +1109,9 @@ static void add_managed_box(Scheme_Custodian *m,
m->data[m->count] = data;
m->mrefs[m->count] = mref;
m->elems++;
adjust_limit_table(m);
m->count++;
}
@ -1112,6 +1138,8 @@ static void remove_managed(Scheme_Custodian_Reference *mr, Scheme_Object *o,
if (old_data)
*old_data = m->data[i];
m->data[i] = NULL;
--m->elems;
adjust_limit_table(m);
break;
}
}
@ -1164,6 +1192,8 @@ static void adjust_custodian_family(void *mgr, void *skip_move)
m = next;
}
adjust_limit_table(parent);
/* Add remaining managed items to parent: */
if (!skip_move) {
for (i = 0; i < r->count; i++) {
@ -1221,6 +1251,9 @@ void insert_custodian(Scheme_Custodian *m, Scheme_Custodian *parent)
CUSTODIAN_FAM(m->global_next) = NULL;
CUSTODIAN_FAM(m->global_prev) = NULL;
}
if (parent)
adjust_limit_table(parent);
}
Scheme_Custodian *scheme_make_custodian(Scheme_Custodian *parent)
@ -1483,6 +1516,7 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
m->count = 0;
m->alloc = 0;
m->elems = 0;
m->boxes = NULL;
m->closers = NULL;
m->data = NULL;
@ -1496,9 +1530,7 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
/* Remove this custodian from its parent */
adjust_custodian_family(m, m);
if (m->has_limit) {
scheme_hash_set(limited_custodians, (Scheme_Object *)m, NULL);
}
adjust_limit_table(m);
m = next_m;
}

2
src/wxxt/contrib/xpm/lib/CrBufFrI.c
View File

@ -36,7 +36,7 @@
\*****************************************************************************/
#include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS)
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>

2
src/wxxt/contrib/xpm/lib/CrDatFrI.c
View File

@ -33,7 +33,7 @@
\*****************************************************************************/
#include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS)
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>

5
src/wxxt/contrib/xpm/lib/WrFFrBuf.c
View File

@ -33,6 +33,11 @@
\*****************************************************************************/
#include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
int
XpmWriteFileFromBuffer(filename, buffer)

5
src/wxxt/contrib/xpm/lib/WrFFrI.c
View File

@ -33,6 +33,11 @@
\*****************************************************************************/
#include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(WriteFile, int, (FILE *file, XpmImage *image, char *name,
XpmInfo *info));

5
src/wxxt/contrib/xpm/lib/create.c
View File

@ -40,6 +40,11 @@
#include "xpmP.h"
#include <ctype.h>
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(xpmVisualType, int, (Visual *visual));

5
src/wxxt/contrib/xpm/lib/data.c
View File

@ -39,6 +39,11 @@ static char *RCS_Version = "$XpmVersion: 3.4g $";
#include "xpmP.h"
#include <ctype.h>
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(ParseComment, int, (xpmData * mdata));

5
src/wxxt/contrib/xpm/lib/hashtab.c
View File

@ -34,6 +34,11 @@
\*****************************************************************************/
#include "xpmP.h"
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(AtomMake, xpmHashAtom, (char *name, void *data));
LFUNC(HashTableGrows, int, (xpmHashTable * table));

5
src/wxxt/contrib/xpm/lib/parse.c
View File

@ -40,6 +40,11 @@
#include "xpmP.h"
#include <ctype.h>
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>
#endif
LFUNC(ParseValues, int, (xpmData *data, unsigned int *width,
unsigned int *height, unsigned int *ncolors,

2
src/wxxt/contrib/xpm/lib/rgb.c
View File

@ -44,7 +44,7 @@
#include "xpmP.h"
#include <ctype.h>
#if defined(SYSV) || defined(SVR4) || defined(VMS)
#if defined(SYSV) || defined(SVR4) || defined(VMS) || defined(__GNUC__)
#include <string.h>
#else
#include <strings.h>

6
src/wxxt/src/DeviceContexts/WindowDC.cc
View File

@ -2867,6 +2867,10 @@ void wxWindowDC::Initialize(wxWindowDC_Xinit* init)
void wxWindowDC::Destroy(void)
{
#ifdef WX_USE_CAIRO
ReleaseCairoDev();
#endif
if (PEN_GC) XFreeGC(DPY, PEN_GC);
if (BRUSH_GC) XFreeGC(DPY, BRUSH_GC);
if (TEXT_GC) XFreeGC(DPY, TEXT_GC);
@ -3726,7 +3730,7 @@ void wxWindowDC::InitCairoDev()
void wxWindowDC::ReleaseCairoDev()
{
if (X->cairo_dev) {
cairo_destroy(CAIRO_DEV);
cairo_destroy_it(CAIRO_DEV);
X->cairo_dev = 0;
}
}

2
src/wxxt/src/wx_cairo.h
View File

@ -24,6 +24,7 @@ typedef cairo_matrix_t cairo_matrix_p;
# define cairo_default_matrix(dev) cairo_identity_matrix(dev)
# undef cairo_init_clip
# define cairo_init_clip(dev) cairo_reset_clip(dev)
# define cairo_destroy_it(c) (cairo_surface_destroy(cairo_get_target(c)), cairo_destroy(c))
# else
/* Old Cairo API (0.5 and up) */
typedef cairo_matrix_t *cairo_matrix_p;
@ -31,5 +32,6 @@ typedef cairo_matrix_t *cairo_matrix_p;
# define cairo__set_matrix(CAIRO_DEV, m) cairo_set_matrix(CAIRO_DEV, m)
# define cairo_set_create_xlib(dev, display, drawable, vis, w, h) \
dev = cairo_create(); cairo_set_target_drawable(dev, wxAPP_DISPLAY, DRAWABLE)
# define cairo_destroy_it(c) cairo_destroy(c)
# endif
#endif