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

avoid compilation of a teachpack in the same way we avoid it in an executable

Browse Source 
svn: r6514
This commit is contained in:
Robby Findler 2007-06-07 14:27:26 +00:00
parent fee8d1efc4
commit 6741e4d3e7
1 changed files with 58 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
collects/lang/htdp-langs.ss
View File

@ -414,24 +414,7 @@
#:literal-expression `(require ,(filename->require-symbol program-filename)) #:literal-expression `(require ,(filename->require-symbol program-filename))
#:cmdline '("-Zmvq") #:cmdline '("-Zmvq")
#:src-filter #:src-filter
(λ (path) (λ (path) (cannot-compile? path))
(call-with-input-file path
(λ (port)
(let ([ok-to-compile-names
(map (λ (x) (format "~s" x))
'(wxtext
(lib "comment-snip.ss" "framework")
(lib "xml-snipclass.ss" "xml")
(lib "scheme-snipclass.ss" "xml")))])
(and (is-wxme-stream? port)
(let-values ([(snip-class-names data-class-names)
(extract-used-classes port)])
(not (and (andmap
(λ (used-name) (member used-name ok-to-compile-names))
snip-class-names)
(andmap
(λ (used-name) (member used-name ok-to-compile-names))
data-class-names)))))))))
#:get-extra-imports #:get-extra-imports
(λ (path cm) (λ (path cm)
(call-with-input-file path (call-with-input-file path
@ -655,6 +638,27 @@
(super-new))) (super-new)))
;; cannot-compile? : path -> boolean
;; returns #t if the file cannot be compiled, #f otherwise
(define (cannot-compile? path)
(call-with-input-file path
(λ (port)
(let ([ok-to-compile-names
(map (λ (x) (format "~s" x))
'(wxtext
(lib "comment-snip.ss" "framework")
(lib "xml-snipclass.ss" "xml")
(lib "scheme-snipclass.ss" "xml")))])
(and (is-wxme-stream? port)
(let-values ([(snip-class-names data-class-names)
(extract-used-classes port)])
(not (and (andmap
(λ (used-name) (member used-name ok-to-compile-names))
snip-class-names)
(andmap
(λ (used-name) (member used-name ok-to-compile-names))
data-class-names)))))))))
(define (get-teachpack-from-user parent) (define (get-teachpack-from-user parent)
(define tp-dir (collection-path "teachpack" "htdp")) (define tp-dir (collection-path "teachpack" "htdp"))
(define columns 2) (define columns 2)
@ -748,35 +752,42 @@
(define (compile-new-teachpack filename) (define (compile-new-teachpack filename)
(let-values ([(_1 short-name _2) (split-path filename)]) (let-values ([(_1 short-name _2) (split-path filename)])
(send compiling-message set-label (cond
(format (string-constant compiling-teachpack) [(cannot-compile? filename)
(path->string short-name))) (post-compilation-gui-cleanup short-name)]
(starting-compilation) [else
(let ([nc (make-custodian)] (send compiling-message set-label
[exn #f]) (format (string-constant compiling-teachpack)
(let ([t (path->string short-name)))
(parameterize ([current-custodian nc]) (starting-compilation)
(thread (λ () (let ([nc (make-custodian)]
(with-handlers ((exn? (λ (x) (set! exn x)))) [exn #f])
(parameterize ([read-accept-reader #t]) (let ([t
(compile-file filename))))))]) (parameterize ([current-custodian nc])
(thread (thread (λ ()
(λ () (with-handlers ((exn? (λ (x) (set! exn x))))
(thread-wait t) (parameterize ([read-accept-reader #t])
(queue-callback (compile-file filename))))))])
(λ () (thread
(cond (λ ()
[exn (thread-wait t)
(message-box (string-constant drscheme) (queue-callback
(exn-message exn)) (λ ()
(delete-file filename) (cond
(update-user-installed-lb)] [exn
[else (message-box (string-constant drscheme)
(update-user-installed-lb) (exn-message exn))
(clear-selection pre-installed-lb) (delete-file filename)
(send user-installed-lb set-string-selection (path->string short-name))]) (update-user-installed-lb)]
(done-compilation) [else
(send compiling-message set-label ""))))))))) (post-compilation-gui-cleanup short-name)])
(done-compilation)
(send compiling-message set-label "")))))))])))
(define (post-compilation-gui-cleanup short-name)
(update-user-installed-lb)
(clear-selection pre-installed-lb)
(send user-installed-lb set-string-selection (path->string short-name)))
(define (starting-compilation) (define (starting-compilation)
(set! compiling? #t) (set! compiling? #t)