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

improved preferences marshalling, also started the job of making the 'your program died' dialog say whether or not it ran out of memory.

Browse Source 
svn: r6051
This commit is contained in:
Robby Findler 2007-04-26 16:33:03 +00:00
parent fa0e23df93
commit ade829139a
1 changed files with 42 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -482,13 +482,17 @@ TODO
(let ([marshall (let ([marshall
(λ (lls) (λ (lls)
(map (λ (ls) (map (λ (ls)
(map (λ (s) (list
(cond (apply
[(is-a? s string-snip%) string-append
(send s get-text 0 (send s get-count))] (reverse
[(string? s) s] (map (λ (s)
[else "'non-string-snip"])) (cond
ls)) [(is-a? s string-snip%)
(send s get-text 0 (send s get-count))]
[(string? s) s]
[else "'non-string-snip"]))
ls)))))
lls))] lls))]
[unmarshall (λ (x) x)]) [unmarshall (λ (x) x)])
(preferences:set-un/marshall (preferences:set-un/marshall
@ -531,7 +535,8 @@ TODO
(make-object image-snip% bitmap) (make-object image-snip% bitmap)
(make-object string-snip% "[err]")))) (make-object string-snip% "[err]"))))
(define (no-user-evaluation-message frame exit-code) (define (no-user-evaluation-message frame exit-code memory-killed?)
; (printf "memory-killed? ~s\n" memory-killed?)
(message-box (message-box
(string-constant evaluation-terminated) (string-constant evaluation-terminated)
(if exit-code (if exit-code
@ -895,6 +900,8 @@ TODO
(field (user-language-settings #f) (field (user-language-settings #f)
(user-teachpack-cache (preferences:get 'drscheme:teachpacks)) (user-teachpack-cache (preferences:get 'drscheme:teachpacks))
(user-custodian-parent #f)
(memory-killed-thread #f)
(user-custodian #f) (user-custodian #f)
(custodian-limit (and (with-handlers ([exn:fail:unsupported? (λ (x) #f)]) (custodian-limit (and (with-handlers ([exn:fail:unsupported? (λ (x) #f)])
(let ([c (make-custodian)]) (let ([c (make-custodian)])
@ -948,7 +955,8 @@ TODO
(let ([canvas (get-active-canvas)]) (let ([canvas (get-active-canvas)])
(and canvas (and canvas
(send canvas get-top-level-window))) (send canvas get-top-level-window)))
user-exit-code)))) user-exit-code
(not (thread-running? memory-killed-thread))))))
(field (need-interaction-cleanup? #f)) (field (need-interaction-cleanup? #f))
(define/private (cleanup-interaction) ; =Kernel=, =Handler= (define/private (cleanup-interaction) ; =Kernel=, =Handler=
@ -1144,9 +1152,16 @@ TODO
(define/private (init-evaluation-thread) ; =Kernel= (define/private (init-evaluation-thread) ; =Kernel=
(set! user-language-settings (send definitions-text get-next-settings)) (set! user-language-settings (send definitions-text get-next-settings))
(set! user-custodian (make-custodian)) (set! user-custodian-parent (make-custodian))
(set! user-custodian (parameterize ([current-custodian user-custodian-parent])
(make-custodian)))
(set! memory-killed-thread
(parameterize ([current-custodian user-custodian-parent])
(thread (λ () (semaphore-wait (make-semaphore 0))))))
(when custodian-limit (when custodian-limit
(custodian-limit-memory user-custodian custodian-limit user-custodian)) (custodian-limit-memory user-custodian-parent
custodian-limit
user-custodian-parent))
(let ([user-eventspace (parameterize ([current-custodian user-custodian]) (let ([user-eventspace (parameterize ([current-custodian user-custodian])
(make-eventspace))]) (make-eventspace))])
(set! user-eventspace-box (make-weak-box user-eventspace)) (set! user-eventspace-box (make-weak-box user-eventspace))
@ -1549,24 +1564,22 @@ TODO
(set-position (last-position)) (set-position (last-position))
(end-edit-sequence)))) (end-edit-sequence))))
(define/public copy-next-previous-expr (define/public (copy-next-previous-expr)
(λ () (let ([previous-exprs (get-previous-exprs)])
(let ([previous-exprs (get-previous-exprs)]) (unless (null? previous-exprs)
(unless (null? previous-exprs) (set! previous-expr-pos
(set! previous-expr-pos (if (< (add1 previous-expr-pos) (length previous-exprs))
(if (< (add1 previous-expr-pos) (length previous-exprs)) (add1 previous-expr-pos)
(add1 previous-expr-pos) 0))
0)) (copy-previous-expr))))
(copy-previous-expr))))) (define/public (copy-prev-previous-expr)
(define/public copy-prev-previous-expr (let ([previous-exprs (get-previous-exprs)])
(λ () (unless (null? previous-exprs)
(let ([previous-exprs (get-previous-exprs)]) (set! previous-expr-pos
(unless (null? previous-exprs) (if (previous-expr-pos . <= . 0)
(set! previous-expr-pos (sub1 (length previous-exprs))
(if (previous-expr-pos . <= . 0) (sub1 previous-expr-pos)))
(sub1 (length previous-exprs)) (copy-previous-expr))))
(sub1 previous-expr-pos)))
(copy-previous-expr)))))
;; private fields ;; private fields
(define global-previous-exprs (preferences:get 'drscheme:console-previous-exprs)) (define global-previous-exprs (preferences:get 'drscheme:console-previous-exprs))