Skip to content

Commit

Permalink
changes that went out in v370p1
Browse files Browse the repository at this point in the history 
svn: r6798
  • Loading branch information
@elibarzilay
elibarzilay committed Jul 2, 2007
1 parent bddb28e commit 048f001
Show file tree
Hide file tree
Showing 5 changed files with 104 additions and 67 deletions.
18 changes: 5 additions & 13 deletions collects/drscheme/private/module-language.ss
View file
Expand Up @@ -158,7 +158,10 @@
"there can only be one expression in the definitions window"
super-result)))]
[(= 4 iteration-number)
#`(eval '(current-namespace (module->namespace '#,(get-full-module-name))))]
#`(eval #,#`(#%app current-namespace
(#%app
module->namespace
'#,(get-full-module-name))))]
[else eof]))))

;; printer settings are just ignored here.
Expand Down Expand Up @@ -405,18 +408,7 @@
(check-filename-matches filename
(syntax-object->datum (syntax name))
unexpanded-stx))


(values v-name
stx)

;; this isn't working ...
#;
(let ([new-name (if filename
(build-name filename)
v-name)])
(values new-name
#`(module #,new-name lang (#%plain-module-begin bodies ...)))))]
(values v-name stx))]
[else
(raise-syntax-error 'module-language
"only module expressions are allowed"
Expand Down
1 change: 1 addition & 0 deletions collects/framework/private/scheme.ss
View file
Expand Up @@ -1721,6 +1721,7 @@
(send define-regexp-text set-value (or (object-name (caddr pref)) ""))
(send lambda-regexp-text set-value (or (object-name (cadddr pref)) ""))))
(preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
(update-gui (preferences:get 'framework:tabify))
main-panel)

)
Expand Down
109 changes: 62 additions & 47 deletions collects/lang/htdp-langs.ss
View file
Expand Up @@ -414,24 +414,7 @@
#:literal-expression `(require ,(filename->require-symbol program-filename))
#:cmdline '("-Zmvq")
#:src-filter
(λ (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)))))))))
(λ (path) (cannot-compile? path))
#:get-extra-imports
(λ (path cm)
(call-with-input-file path
Expand Down Expand Up @@ -655,6 +638,27 @@

(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 tp-dir (collection-path "teachpack" "htdp"))
(define columns 2)
Expand Down Expand Up @@ -748,34 +752,42 @@

(define (compile-new-teachpack filename)
(let-values ([(_1 short-name _2) (split-path filename)])
(send compiling-message set-label
(format (string-constant compiling-teachpack)
(path->string short-name)))
(starting-compilation)
(let ([nc (make-custodian)]
[exn #f])
(let ([t
(parameterize ([current-custodian nc])
(thread (λ ()
(with-handlers ((exn? (λ (x) (set! exn x))))
(compile-file filename)))))])
(thread
(λ ()
(thread-wait t)
(queue-callback
(λ ()
(cond
[exn
(message-box (string-constant drscheme)
(exn-message exn))
(delete-file filename)
(update-user-installed-lb)]
[else
(update-user-installed-lb)
(clear-selection pre-installed-lb)
(send user-installed-lb set-string-selection (path->string short-name))])
(done-compilation)
(send compiling-message set-label "")))))))))
(cond
[(cannot-compile? filename)
(post-compilation-gui-cleanup short-name)]
[else
(send compiling-message set-label
(format (string-constant compiling-teachpack)
(path->string short-name)))
(starting-compilation)
(let ([nc (make-custodian)]
[exn #f])
(let ([t
(parameterize ([current-custodian nc])
(thread (λ ()
(with-handlers ((exn? (λ (x) (set! exn x))))
(parameterize ([read-accept-reader #t])
(compile-file filename))))))])
(thread
(λ ()
(thread-wait t)
(queue-callback
(λ ()
(cond
[exn
(message-box (string-constant drscheme)
(exn-message exn))
(delete-file filename)
(update-user-installed-lb)]
[else
(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)
(set! compiling? #t)
Expand All @@ -790,7 +802,10 @@
(define (update-user-installed-lb)
(let ([files
(if (directory-exists? teachpack-installation-dir)
(map path->string (directory-list teachpack-installation-dir))
(map path->string
(filter
(λ (x) (file-exists? (build-path teachpack-installation-dir x)))
(directory-list teachpack-installation-dir)))
'())])
(send user-installed-lb set (sort files string<=?))))

Expand Down
31 changes: 25 additions & 6 deletions collects/slideshow/tool.ss
View file
Expand Up @@ -279,8 +279,8 @@ pict snip :
(error 'pict-snip "expected a pict to be the result of each embedded snip, got ~e"
pict))
(let* ([bm (make-object bitmap%
(inexact->exact (ceiling w))
(inexact->exact (ceiling h)))]
(max 1 (inexact->exact (ceiling w)))
(max 1 (inexact->exact (ceiling h))))]
[bdc (make-object bitmap-dc% bm)])
(send bdc clear)
(draw-pict pict bdc 0 0)
Expand Down Expand Up @@ -889,14 +889,33 @@ pict snip :

(define orig-namespace (current-namespace))

(define (pict->image-snip p)
(let* ([pict-width (dynamic-require '(lib "mrpict.ss" "texpict") 'pict-width)]
[pict-height (dynamic-require '(lib "mrpict.ss" "texpict") 'pict-height)]
[draw-pict (dynamic-require '(lib "mrpict.ss" "texpict") 'draw-pict)]
[bm (make-object bitmap%
(max 1 (inexact->exact (ceiling (pict-width p))))
(max 1 (inexact->exact (ceiling (pict-height p)))))]
[bdc (make-object bitmap-dc% bm)])
(send bdc clear)
(draw-pict p bdc 0 0)
(send bdc set-bitmap #f)
(make-object image-snip% bm)))

(drscheme:language:add-snip-value
;; Convert to print?
(lambda (x) (pict? x))
(lambda (x)
;; if the require fails, then we cannot display the pict.
;; this can happen when, for example, there is no mred module
;; in the namespace
(let ([pict? (with-handlers ((exn? (λ (x) #f)))
(dynamic-require '(lib "mrpict.ss" "texpict") 'pict?))])
(and pict?
(pict? x))))
;; Converter:
(lambda (pict) (new pict-value-snip% (pict pict)))
pict->image-snip
;; Namespace setup:
(lambda ()
(namespace-attach-module orig-namespace '(lib "mrpict.ss" "texpict"))))
(λ () (dynamic-require '(lib "mrpict.ss" "texpict") #f)))

(define lib-pict-snipclass (make-object lib-pict-snipclass%))
(send lib-pict-snipclass set-version 2)
Expand Down
12 changes: 11 additions & 1 deletion collects/version/patchlevel.ss
View file
@@ -1,5 +1,15 @@
;; this file contains the current patch level of DrScheme
;; it is usually `0' in the repository, and changed only when a patch is made.

;; This PLT installation has a patch applied (v370), which fixes the use of
;; teachpacks that contain images. Files that were patched:
;; collects/version/patchlevel.ss
;; collects/drscheme/private/module-language.ss
;; collects/framework/private/scheme.ss
;; collects/slideshow/tool.ss
;; collects/lang/htdp-langs.ss
;; collects/tests/drscheme/module-lang-test.ss

(module patchlevel mzscheme
(define patchlevel 0)
(define patchlevel 1)
(provide patchlevel))

0 comments on commit 048f001

Please sign in to comment.