From a2cbc683780f687260f8f5b30d1f70d4a3bd4661 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Apr 2007 23:00:38 +0000 Subject: [PATCH] improve and module-ize mxdemo, change executable creator to prefer exetsnions (such as mxmain) svn: r6012 --- collects/compiler/embed-unit.ss | 6 +- collects/mysterx/doc.txt | 33 ++- collects/mysterx/mxdemo.ss | 378 +++++++++++++++++--------------- collects/syntax/doc.txt | 11 +- collects/syntax/modcode.ss | 14 +- 5 files changed, 250 insertions(+), 192 deletions(-) diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 641ffa4014..4f5752765b 100644 --- a/collects/compiler/embed-unit.ss +++ b/collects/compiler/embed-unit.ss @@ -364,7 +364,9 @@ (error 'create-embedding-executable "cannot use a _loader extension: ~e" file) - (make-extension file)))))] + (make-extension file)))) + ;; Prefer extensions if we're handling them: + (not on-extension))] [name (let-values ([(base name dir?) (split-path filename)]) (path->string (path-replace-suffix name #"")))] [prefix (let ([a (assoc filename prefixes)]) @@ -373,6 +375,8 @@ (generate-prefix)))]) (cond [(extension? code) + (when verbose? + (fprintf (current-error-port) " using extension: ~s~n" (extension-path code))) (set-box! codes (cons (make-mod filename module-path code name prefix (string->symbol diff --git a/collects/mysterx/doc.txt b/collects/mysterx/doc.txt index c4413e017d..1e4cbb54c6 100644 --- a/collects/mysterx/doc.txt +++ b/collects/mysterx/doc.txt @@ -20,7 +20,7 @@ _MysterX_ Installation ------------ - Two Windows .DLL's support low-level operations in MysterX: + Two Windows DLLs support low-level operations in MysterX: "myspage.dll" and "myssink.dll". Both are installed in the registry (using `REGSVR32 ') when Setup PLT runs the the MysterX post-installer. If you move the location of your PLT installation, @@ -30,6 +30,37 @@ _MysterX_ to version 369.4, myssink.dll was version-specific; its GUID was changed when it was made version-independent.) + If you build a stand-alone executable that uses MysterX, you need to + specifically include "myspage.dll" and "myssink.dll" with your + distribution, and the DLLs will need to be registered on the end + user's machine. One way to do that is to include the following little + setup program (as an executable) in your distribution: + + (module setup mzscheme + (require (lib "runtime-path.ss") + (lib "process.ss")) + + ;; Ensure that DLLs are included with the distibution: + (define-runtime-path myspage-dll '(so "myspage")) + (define-runtime-path myssink-dll '(so "myssink")) + + ;; Register the DLLs: + (define regsvr32 + (path->string (find-executable-path "regsvr32.exe" #f))) + (system* regsvr32 (path->string myspage-dll)) + (system* regsvr32 (path->string myssink-dll))) + + Running a Demo + -------------- + + Try + + (require (lib "mxdemo.ss" "mysterx")) + + The demo requires the MSCal Calendar control. The calendar control + is normally installed with Microsoft Office, but it can also be + downloaded from elsewhere; look for "mscal.ocx". + Loading ------- diff --git a/collects/mysterx/mxdemo.ss b/collects/mysterx/mxdemo.ss index aa7c797124..dec99ea985 100644 --- a/collects/mysterx/mxdemo.ss +++ b/collects/mysterx/mxdemo.ss @@ -1,24 +1,38 @@ ;;; mxdemo.ss -- demo program for MysterX -;;; requires Office 97/2000/XP to be installed for Calendar Control to work +;;; Requires the MSCal Calendar control. +;;; The calendar control is normally installed with +;;; MS Office, but it can also be downloaded from +;;; elsewhere. Look for "mscal.ocx". -(require (lib "class.ss")) -(require (lib "mysterx.ss" "mysterx")) +(module mxdemo mzscheme + + (require (lib "class.ss")) + (require (lib "mysterx.ss" "mysterx")) + + (require (lib "runtime-path.ss") + (lib "system.ss")) + ;; Ensure that DLLs are included with the distibution: + (define-runtime-path myspage-dll (so "myspage")) + (define-runtime-path myssink-dll (so "myssink")) + ;; Register them every time we start: + (system* "regsvr32.exe" "/s" myspage-dll) + (system* "regsvr32.exe" "/s" myssink-dll) -; the browser with the calendar - -(define calwb (instantiate mx-browser% - () ; no by-position initializers - (label "Calendar control") - (height 400) - (width 350) - (y 100) - (x 100) - (style-options '(scrollbars)))) - -(define caldoc (send calwb current-document)) - -(send caldoc insert-html + ; the browser with the calendar + + (define calwb (instantiate mx-browser% + () ; no by-position initializers + (label "Calendar control") + (height 400) + (width 350) + (y 100) + (x 100) + (style-options '(scrollbars)))) + + (define caldoc (send calwb current-document)) + + (send caldoc insert-html (string-append "

MysterX Demo

" "

" @@ -27,168 +41,174 @@ (progid->html "MSCAL.Calendar.7" 300 200) "

" "

")) - -(define cal (car (send caldoc objects))) - -; the control panel document -(define ctrlwb (make-object mx-browser% "Control Panel" 180 350 600 300 '())) -(define ctrldoc (send ctrlwb current-document)) - -(send ctrldoc insert-html + + (define cal (car (send caldoc objects))) + + ; the control panel document + (define ctrlwb (make-object mx-browser% "Control Panel" 180 350 600 300 '())) + (define ctrldoc (send ctrlwb current-document)) + + (send ctrldoc insert-html (string-append - "" - - "" - - "" - "" - "" - - "" - "" - "" - "" - "" - - "" - "" - "" - "" - "" - - "" - "" - "" - "" - "" - - "
Keypress here
Day
Month
Year
" - - "" - - "" - - "
" - - "
" - - "" - - "" - "" - "" - "" - - "
" - - "" - - "" - - "
" - - "" - - "" - - "
" - - "

" - - "" - - "" - - "
Click on the calendar
")) - -(define reflector (send ctrldoc find-element "TD" "event-reflector")) - -(com-register-event-handler - cal "Click" - (lambda () - (send reflector set-color! 'white) - (send reflector set-background-color! 'blue) - (thread - (lambda () - (sleep 0.25) - (send reflector set-color! 'black) - (send reflector set-background-color! 'white))))) - -(define (about-handler ev) - (when (send ev click?) - (com-invoke cal "AboutBox"))) - -(define (hide-handler ev) - (when (send ev click?) - (send calwb show #f))) - -(define (show-handler ev) - (when (send ev click?) - (send calwb show #t))) - -(define rub-me-handler - (let ([count 0]) - (lambda (ev) - (when (send ev mousemove?) - (printf "mousemove #~a, but who's counting?~n" count) - (set! count (add1 count)))))) - -(define (today-handler ev) - (when (send ev click?) - (com-invoke cal "Today"))) - -(define (yesterday-handler ev) - (when (send ev click?) - (com-invoke cal "PreviousDay"))) - -(define (tomorrow-handler ev) - (when (send ev click?) - (com-invoke cal "NextDay"))) - -(define (last-month-handler ev) - (when (send ev click?) - (com-invoke cal "PreviousMonth"))) - -(define (next-month-handler ev) - (when (send ev click?) - (com-invoke cal "NextMonth"))) - -(define (last-year-handler ev) - (when (send ev click?) - (com-invoke cal "PreviousYear"))) - -(define (next-year-handler ev) - (when (send ev click?) - (com-invoke cal "NextYear"))) - -(define button-handlers - `(("About" ,about-handler) - ("Hide" ,hide-handler) - ("Show" ,show-handler) - ("Rub-me" ,rub-me-handler) - ("Today" ,today-handler) - ("Yesterday" ,yesterday-handler) - ("Tomorrow" ,tomorrow-handler) - ("Last-month" ,last-month-handler) - ("Next-month" ,next-month-handler) - ("Last-year" ,last-year-handler) - ("Next-year" ,next-year-handler))) - -(send ctrlwb register-event-handler - (send ctrldoc find-element "CAPTION" "Caption") + "" + + "" + + "" + "" + "" + + "" + "" + "" + "" + "" + + "" + "" + "" + "" + "" + + "" + "" + "" + "" + "" + + "
Keypress here
Day
Month
Year
" + + "" + + "" + + "
" + + "

" + + "" + + "" + "" + "" + "" + + "
" + + "" + "" + "
" + + "" + "" + "
" + + "" + "" + "
" + + "

" + + "" + + "" + + "
Click on the calendar
")) + + (define reflector (send ctrldoc find-element "TD" "event-reflector")) + + (com-register-event-handler + cal "Click" + (lambda () + (send reflector set-color! 'white) + (send reflector set-background-color! 'blue) + (thread + (lambda () + (sleep 0.25) + (send reflector set-color! 'black) + (send reflector set-background-color! 'white))))) + + (define (quit-handler ev) + (when (send ev click?) + (exit))) + + (define (about-handler ev) + (when (send ev click?) + (com-invoke cal "AboutBox"))) + + (define (hide-handler ev) + (when (send ev click?) + (send calwb show #f))) + + (define (show-handler ev) + (when (send ev click?) + (send calwb show #t))) + + (define rub-me-handler + (let ([count 0]) + (lambda (ev) + (when (send ev mousemove?) + (printf "mousemove #~a, but who's counting?~n" count) + (set! count (add1 count)))))) + + (define (today-handler ev) + (when (send ev click?) + (com-invoke cal "Today"))) + + (define (yesterday-handler ev) + (when (send ev click?) + (com-invoke cal "PreviousDay"))) + + (define (tomorrow-handler ev) + (when (send ev click?) + (com-invoke cal "NextDay"))) + + (define (last-month-handler ev) + (when (send ev click?) + (com-invoke cal "PreviousMonth"))) + + (define (next-month-handler ev) + (when (send ev click?) + (com-invoke cal "NextMonth"))) + + (define (last-year-handler ev) + (when (send ev click?) + (com-invoke cal "PreviousYear"))) + + (define (next-year-handler ev) + (when (send ev click?) + (com-invoke cal "NextYear"))) + + (define button-handlers + `(("Quit" ,quit-handler) + ("About" ,about-handler) + ("Hide" ,hide-handler) + ("Show" ,show-handler) + ("Rub-me" ,rub-me-handler) + ("Today" ,today-handler) + ("Yesterday" ,yesterday-handler) + ("Tomorrow" ,tomorrow-handler) + ("Last-month" ,last-month-handler) + ("Next-month" ,next-month-handler) + ("Last-year" ,last-year-handler) + ("Next-year" ,next-year-handler))) + + (send ctrlwb register-event-handler + (send ctrldoc find-element "CAPTION" "Caption") (lambda (ev) (when (send ev keypress?) - (printf "ooh that tickles~n")))) - -(for-each - (lambda (sym-handler) - (send ctrlwb register-event-handler - (send ctrldoc find-element - "BUTTON" ; tag - (car sym-handler)) ; id - (cadr sym-handler))) ; handler - button-handlers) - -(send ctrlwb handle-events) - - + (printf "ooh that tickles~n")))) + + (for-each + (lambda (sym-handler) + (send ctrlwb register-event-handler + (send ctrldoc find-element + "BUTTON" ; tag + (car sym-handler)) ; id + (cadr sym-handler))) ; handler + button-handlers) + + (send ctrlwb handle-events) + + ;; Wait + (sync never-evt)) diff --git a/collects/syntax/doc.txt b/collects/syntax/doc.txt index 7c6e6bf587..86f38c7bac 100644 --- a/collects/syntax/doc.txt +++ b/collects/syntax/doc.txt @@ -323,7 +323,7 @@ _modread.ss_: reading module source code _modcode.ss_: getting module compiled code ====================================================================== -> (get-module-code path [compiled-subdir compile-proc ext-proc]) - +> (get-module-code path [compiled-subdir compile-proc ext-proc prefer-ext?]) - returns a compiled expression for the declaration of the module specified by `module-path-v'. The `module-path-v' argument is a quoted module path, as for MzScheme's `dynamic-require' using the @@ -347,10 +347,11 @@ _modcode.ss_: getting module compiled code (in one of the directories specified by `compiled-subdir'), then it is used instead of the source. Native-code versions of `path' are ignored --- unless only a native-code version exists (i.e., `path' - itself does not exist). If only a native-code version exists, it is - supplied to `ext-proc' when `ext-proc' is #f, or an exception is - raised (to report that an extension file cannot be used) when - `ext-proc' is #f. + itself does not exist), or `prefer-ext?' is true and the native-code + file is not a _loader variant. If a native-code version is prefer or + is the only file that exists, it is supplied to `ext-proc' when + `ext-proc' is #f, or an exception is raised (to report that an + extension file cannot be used) when `ext-proc' is #f. > moddep-current-open-input-file diff --git a/collects/syntax/modcode.ss b/collects/syntax/modcode.ss index f8b4e23e1d..7e2269c3ad 100644 --- a/collects/syntax/modcode.ss +++ b/collects/syntax/modcode.ss @@ -14,7 +14,8 @@ [get-module-code ([path-string?] [(and/c path-string? relative-path?) (any/c . -> . any) - (or/c false/c (path? boolean? . -> . any))] + (or/c false/c (path? boolean? . -> . any)) + any/c] . opt-> . any)]) @@ -64,7 +65,7 @@ (define/kw (get-module-code path #:optional - [sub-path "compiled"] [compiler compile] [extension-handler #f]) + [sub-path "compiled"] [compiler compile] [extension-handler #f] [prefer-so? #f]) (unless (path-string? path) (raise-type-error 'get-module-code "path or string (sans nul)" path)) (let*-values ([(path) (resolve path)] @@ -90,16 +91,17 @@ (cond ;; Use .zo, if it's new enough [(date>=? zo path-d) (read-one zo #f)] - ;; Otherwise, use source if it exists - [path-d (with-dir (lambda () (compiler (read-one path #t))))] - ;; No source --- maybe there's an .so? - [(and (not path-d) (date>=? so path-d)) + ;; Maybe there's an .so? Use it only if we don't prefer source. + [(and (or (not path-d) prefer-so?) + (date>=? so path-d)) (if extension-handler (extension-handler so #f) (raise (make-exn:get-module-code (format "get-module-code: cannot use extension file; ~e" so) (current-continuation-marks) so)))] + ;; Use source if it exists + [path-d (with-dir (lambda () (compiler (read-one path #t))))] ;; Or maybe even a _loader.so? [(and (not path-d) (date>=? _loader-so path-d)