Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

changes that went out in v370p1

svn: r6798
  • Loading branch information...
commit 048f0015dcfed34ccffb3f8fdc24b9d18bc42e58 1 parent bddb28e
@elibarzilay elibarzilay authored
View
18 collects/drscheme/private/module-language.ss
@@ -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.
@@ -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"
View
1  collects/framework/private/scheme.ss
@@ -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)
)
View
109 collects/lang/htdp-langs.ss
@@ -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
@@ -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)
@@ -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)
@@ -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<=?))))
View
31 collects/slideshow/tool.ss
@@ -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)
@@ -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)
View
12 collects/version/patchlevel.ss
@@ -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))
Please sign in to comment.
Something went wrong with that request. Please try again.