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

improve and module-ize mxdemo, change executable creator to prefer exetsnions (such as mxmain)

Browse Source 
svn: r6012
This commit is contained in:
Matthew Flatt 2007-04-21 23:00:38 +00:00
parent 6102d0a6a6
commit a2cbc68378
5 changed files with 250 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/compiler/embed-unit.ss
View File

@ -364,7 +364,9 @@
(error 'create-embedding-executable (error 'create-embedding-executable
"cannot use a _loader extension: ~e" "cannot use a _loader extension: ~e"
file) 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)]) [name (let-values ([(base name dir?) (split-path filename)])
(path->string (path-replace-suffix name #"")))] (path->string (path-replace-suffix name #"")))]
[prefix (let ([a (assoc filename prefixes)]) [prefix (let ([a (assoc filename prefixes)])
@ -373,6 +375,8 @@
(generate-prefix)))]) (generate-prefix)))])
(cond (cond
[(extension? code) [(extension? code)
(when verbose?
(fprintf (current-error-port) " using extension: ~s~n" (extension-path code)))
(set-box! codes (set-box! codes
(cons (make-mod filename module-path code (cons (make-mod filename module-path code
name prefix (string->symbol name prefix (string->symbol

33
collects/mysterx/doc.txt
View File

@ -20,7 +20,7 @@ _MysterX_
Installation 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 "myspage.dll" and "myssink.dll". Both are installed in the registry
(using `REGSVR32 <name-of-DLL>') when Setup PLT runs the the MysterX (using `REGSVR32 <name-of-DLL>') when Setup PLT runs the the MysterX
post-installer. If you move the location of your PLT installation, 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 to version 369.4, myssink.dll was version-specific; its GUID was
changed when it was made version-independent.) 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 Loading
------- -------

378
collects/mysterx/mxdemo.ss
View File

@ -1,24 +1,38 @@
;;; mxdemo.ss -- demo program for MysterX ;;; 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")) (module mxdemo mzscheme
(require (lib "mysterx.ss" "mysterx"))
(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 ; the browser with the calendar
(define calwb (instantiate mx-browser% (define calwb (instantiate mx-browser%
() ; no by-position initializers () ; no by-position initializers
(label "Calendar control") (label "Calendar control")
(height 400) (height 400)
(width 350) (width 350)
(y 100) (y 100)
(x 100) (x 100)
(style-options '(scrollbars)))) (style-options '(scrollbars))))
(define caldoc (send calwb current-document)) (define caldoc (send calwb current-document))
(send caldoc insert-html (send caldoc insert-html
(string-append (string-append
"<H1 id=\"mx-header\">MysterX Demo</H1>" "<H1 id=\"mx-header\">MysterX Demo</H1>"
"<p>" "<p>"
@ -27,168 +41,174 @@
(progid->html "MSCAL.Calendar.7" 300 200) (progid->html "MSCAL.Calendar.7" 300 200)
"<p>" "<p>"
"<H3 id=\"event-header\"></H3>")) "<H3 id=\"event-header\"></H3>"))
(define cal (car (send caldoc objects))) (define cal (car (send caldoc objects)))
; the control panel document ; the control panel document
(define ctrlwb (make-object mx-browser% "Control Panel" 180 350 600 300 '())) (define ctrlwb (make-object mx-browser% "Control Panel" 180 350 600 300 '()))
(define ctrldoc (send ctrlwb current-document)) (define ctrldoc (send ctrlwb current-document))
(send ctrldoc insert-html (send ctrldoc insert-html
(string-append (string-append
"<table align = center>" "<table align = center>"
"<caption id=\"Caption\"><b>Keypress here</b></caption>" "<caption id=\"Caption\"><b>Keypress here</b></caption>"
"<colgroup align=left>" "<colgroup align=left>"
"<colgroup align=center>" "<colgroup align=center>"
"<colgroup align=right>" "<colgroup align=right>"
"<tr>" "<tr>"
"<td><BUTTON id=\"Yesterday\" style=\"color: blue\">&LT----</BUTTON></td>" "<td><BUTTON id=\"Yesterday\" style=\"color: blue\">&LT----</BUTTON></td>"
"<td><b>Day</b></td>" "<td><b>Day</b></td>"
"<td><BUTTON id=\"Tomorrow\" style=\"color: red\">----&GT</BUTTON></td>" "<td><BUTTON id=\"Tomorrow\" style=\"color: red\">----&GT</BUTTON></td>"
"</tr>" "</tr>"
"<tr>" "<tr>"
"<td><BUTTON id=\"Last-month\" style=\"color: green\">&LT----</BUTTON></td>" "<td><BUTTON id=\"Last-month\" style=\"color: green\">&LT----</BUTTON></td>"
"<td><b>Month</b></td>" "<td><b>Month</b></td>"
"<td><BUTTON id=\"Next-month\" style=\"color: indigo\">----&GT</BUTTON></td>" "<td><BUTTON id=\"Next-month\" style=\"color: indigo\">----&GT</BUTTON></td>"
"</tr>" "</tr>"
"<tr>" "<tr>"
"<td><BUTTON id=\"Last-year\" style=\"color: yellow\">&LT----</BUTTON></td>" "<td><BUTTON id=\"Last-year\" style=\"color: yellow\">&LT----</BUTTON></td>"
"<td><b>Year</b></td>" "<td><b>Year</b></td>"
"<td><BUTTON id=\"Next-year\" style=\"color: purple\">----&GT</BUTTON></td>" "<td><BUTTON id=\"Next-year\" style=\"color: purple\">----&GT</BUTTON></td>"
"</tr>" "</tr>"
"</table>" "</table>"
"<table align=center>" "<table align=center>"
"<td><BUTTON id=\"Today\">Today</BUTTON></td>" "<td><BUTTON id=\"Today\">Today</BUTTON></td>"
"</table>" "</table>"
"<hr>" "<hr>"
"<table align=center>" "<table align=center>"
"<tr>" "<tr>"
"<td><BUTTON id=\"Hide\">Hide</BUTTON></td>" "<td><BUTTON id=\"Hide\">Hide</BUTTON></td>"
"<td><BUTTON id=\"Show\">Show</BUTTON></td>" "<td><BUTTON id=\"Show\">Show</BUTTON></td>"
"</tr>" "</tr>"
"</table>" "</table>"
"<table align=center>" "<table align=center>"
"<td><BUTTON id=\"Rub-me\">Rub me!</BUTTON></td>"
"<td><BUTTON id=\"Rub-me\">Rub me!</BUTTON></td>" "</table>"
"</table>" "<table align=center>"
"<td><BUTTON id=\"About\">About</BUTTON></td>"
"<table align=center>" "</table>"
"<td><BUTTON id=\"About\">About</BUTTON></td>" "<table align=center>"
"<td><BUTTON id=\"Quit\">Quit</BUTTON></td>"
"</table>" "</table>"
"<p>" "<p>"
"<table align=center>" "<table align=center>"
"<td id=\"event-reflector\">Click on the calendar</td>" "<td id=\"event-reflector\">Click on the calendar</td>"
"</table>")) "</table>"))
(define reflector (send ctrldoc find-element "TD" "event-reflector")) (define reflector (send ctrldoc find-element "TD" "event-reflector"))
(com-register-event-handler (com-register-event-handler
cal "Click" cal "Click"
(lambda () (lambda ()
(send reflector set-color! 'white) (send reflector set-color! 'white)
(send reflector set-background-color! 'blue) (send reflector set-background-color! 'blue)
(thread (thread
(lambda () (lambda ()
(sleep 0.25) (sleep 0.25)
(send reflector set-color! 'black) (send reflector set-color! 'black)
(send reflector set-background-color! 'white))))) (send reflector set-background-color! 'white)))))
(define (about-handler ev) (define (quit-handler ev)
(when (send ev click?) (when (send ev click?)
(com-invoke cal "AboutBox"))) (exit)))
(define (hide-handler ev) (define (about-handler ev)
(when (send ev click?) (when (send ev click?)
(send calwb show #f))) (com-invoke cal "AboutBox")))
(define (show-handler ev) (define (hide-handler ev)
(when (send ev click?) (when (send ev click?)
(send calwb show #t))) (send calwb show #f)))
(define rub-me-handler (define (show-handler ev)
(let ([count 0]) (when (send ev click?)
(lambda (ev) (send calwb show #t)))
(when (send ev mousemove?)
(printf "mousemove #~a, but who's counting?~n" count) (define rub-me-handler
(set! count (add1 count)))))) (let ([count 0])
(lambda (ev)
(define (today-handler ev) (when (send ev mousemove?)
(when (send ev click?) (printf "mousemove #~a, but who's counting?~n" count)
(com-invoke cal "Today"))) (set! count (add1 count))))))
(define (yesterday-handler ev) (define (today-handler ev)
(when (send ev click?) (when (send ev click?)
(com-invoke cal "PreviousDay"))) (com-invoke cal "Today")))
(define (tomorrow-handler ev) (define (yesterday-handler ev)
(when (send ev click?) (when (send ev click?)
(com-invoke cal "NextDay"))) (com-invoke cal "PreviousDay")))
(define (last-month-handler ev) (define (tomorrow-handler ev)
(when (send ev click?) (when (send ev click?)
(com-invoke cal "PreviousMonth"))) (com-invoke cal "NextDay")))
(define (next-month-handler ev) (define (last-month-handler ev)
(when (send ev click?) (when (send ev click?)
(com-invoke cal "NextMonth"))) (com-invoke cal "PreviousMonth")))
(define (last-year-handler ev) (define (next-month-handler ev)
(when (send ev click?) (when (send ev click?)
(com-invoke cal "PreviousYear"))) (com-invoke cal "NextMonth")))
(define (next-year-handler ev) (define (last-year-handler ev)
(when (send ev click?) (when (send ev click?)
(com-invoke cal "NextYear"))) (com-invoke cal "PreviousYear")))
(define button-handlers (define (next-year-handler ev)
`(("About" ,about-handler) (when (send ev click?)
("Hide" ,hide-handler) (com-invoke cal "NextYear")))
("Show" ,show-handler)
("Rub-me" ,rub-me-handler) (define button-handlers
("Today" ,today-handler) `(("Quit" ,quit-handler)
("Yesterday" ,yesterday-handler) ("About" ,about-handler)
("Tomorrow" ,tomorrow-handler) ("Hide" ,hide-handler)
("Last-month" ,last-month-handler) ("Show" ,show-handler)
("Next-month" ,next-month-handler) ("Rub-me" ,rub-me-handler)
("Last-year" ,last-year-handler) ("Today" ,today-handler)
("Next-year" ,next-year-handler))) ("Yesterday" ,yesterday-handler)
("Tomorrow" ,tomorrow-handler)
(send ctrlwb register-event-handler ("Last-month" ,last-month-handler)
(send ctrldoc find-element "CAPTION" "Caption") ("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) (lambda (ev)
(when (send ev keypress?) (when (send ev keypress?)
(printf "ooh that tickles~n")))) (printf "ooh that tickles~n"))))
(for-each (for-each
(lambda (sym-handler) (lambda (sym-handler)
(send ctrlwb register-event-handler (send ctrlwb register-event-handler
(send ctrldoc find-element (send ctrldoc find-element
"BUTTON" ; tag "BUTTON" ; tag
(car sym-handler)) ; id (car sym-handler)) ; id
(cadr sym-handler))) ; handler (cadr sym-handler))) ; handler
button-handlers) button-handlers)
(send ctrlwb handle-events) (send ctrlwb handle-events)
;; Wait
(sync never-evt))

11
collects/syntax/doc.txt
View File

@ -323,7 +323,7 @@ _modread.ss_: reading module source code
_modcode.ss_: getting module compiled 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 returns a compiled expression for the declaration of the module
specified by `module-path-v'. The `module-path-v' argument is a specified by `module-path-v'. The `module-path-v' argument is a
quoted module path, as for MzScheme's `dynamic-require' using the 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 (in one of the directories specified by `compiled-subdir'), then it
is used instead of the source. Native-code versions of `path' are is used instead of the source. Native-code versions of `path' are
ignored --- unless only a native-code version exists (i.e., `path' ignored --- unless only a native-code version exists (i.e., `path'
itself does not exist). If only a native-code version exists, it is itself does not exist), or `prefer-ext?' is true and the native-code
supplied to `ext-proc' when `ext-proc' is #f, or an exception is file is not a _loader variant. If a native-code version is prefer or
raised (to report that an extension file cannot be used) when is the only file that exists, it is supplied to `ext-proc' when
`ext-proc' is #f. `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 > moddep-current-open-input-file

14
collects/syntax/modcode.ss
View File

@ -14,7 +14,8 @@
[get-module-code ([path-string?] [get-module-code ([path-string?]
[(and/c path-string? relative-path?) [(and/c path-string? relative-path?)
(any/c . -> . any) (any/c . -> . any)
(or/c false/c (path? boolean? . -> . any))] (or/c false/c (path? boolean? . -> . any))
any/c]
. opt-> . . opt-> .
any)]) any)])
@ -64,7 +65,7 @@
(define/kw (get-module-code path (define/kw (get-module-code path
#:optional #:optional
[sub-path "compiled"] [compiler compile] [extension-handler #f]) [sub-path "compiled"] [compiler compile] [extension-handler #f] [prefer-so? #f])
(unless (path-string? path) (unless (path-string? path)
(raise-type-error 'get-module-code "path or string (sans nul)" path)) (raise-type-error 'get-module-code "path or string (sans nul)" path))
(let*-values ([(path) (resolve path)] (let*-values ([(path) (resolve path)]
@ -90,16 +91,17 @@
(cond (cond
;; Use .zo, if it's new enough ;; Use .zo, if it's new enough
[(date>=? zo path-d) (read-one zo #f)] [(date>=? zo path-d) (read-one zo #f)]
;; Otherwise, use source if it exists ;; Maybe there's an .so? Use it only if we don't prefer source.
[path-d (with-dir (lambda () (compiler (read-one path #t))))] [(and (or (not path-d) prefer-so?)
;; No source --- maybe there's an .so? (date>=? so path-d))
[(and (not path-d) (date>=? so path-d))
(if extension-handler (if extension-handler
(extension-handler so #f) (extension-handler so #f)
(raise (make-exn:get-module-code (raise (make-exn:get-module-code
(format "get-module-code: cannot use extension file; ~e" so) (format "get-module-code: cannot use extension file; ~e" so)
(current-continuation-marks) (current-continuation-marks)
so)))] so)))]
;; Use source if it exists
[path-d (with-dir (lambda () (compiler (read-one path #t))))]
;; Or maybe even a _loader.so? ;; Or maybe even a _loader.so?
[(and (not path-d) [(and (not path-d)
(date>=? _loader-so path-d) (date>=? _loader-so path-d)