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
"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

33
collects/mysterx/doc.txt
View File

@ -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 <name-of-DLL>') 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
-------

378
collects/mysterx/mxdemo.ss
View File

@ -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
"<H1 id=\"mx-header\">MysterX Demo</H1>"
"<p>"
@ -27,168 +41,174 @@
(progid->html "MSCAL.Calendar.7" 300 200)
"<p>"
"<H3 id=\"event-header\"></H3>"))
(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
"<table align = center>"
"<caption id=\"Caption\"><b>Keypress here</b></caption>"
"<colgroup align=left>"
"<colgroup align=center>"
"<colgroup align=right>"
"<tr>"
"<td><BUTTON id=\"Yesterday\" style=\"color: blue\">&LT----</BUTTON></td>"
"<td><b>Day</b></td>"
"<td><BUTTON id=\"Tomorrow\" style=\"color: red\">----&GT</BUTTON></td>"
"</tr>"
"<tr>"
"<td><BUTTON id=\"Last-month\" style=\"color: green\">&LT----</BUTTON></td>"
"<td><b>Month</b></td>"
"<td><BUTTON id=\"Next-month\" style=\"color: indigo\">----&GT</BUTTON></td>"
"</tr>"
"<tr>"
"<td><BUTTON id=\"Last-year\" style=\"color: yellow\">&LT----</BUTTON></td>"
"<td><b>Year</b></td>"
"<td><BUTTON id=\"Next-year\" style=\"color: purple\">----&GT</BUTTON></td>"
"</tr>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"Today\">Today</BUTTON></td>"
"</table>"
"<hr>"
"<table align=center>"
"<tr>"
"<td><BUTTON id=\"Hide\">Hide</BUTTON></td>"
"<td><BUTTON id=\"Show\">Show</BUTTON></td>"
"</tr>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"Rub-me\">Rub me!</BUTTON></td>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"About\">About</BUTTON></td>"
"</table>"
"<p>"
"<table align=center>"
"<td id=\"event-reflector\">Click on the calendar</td>"
"</table>"))
(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")
"<table align = center>"
"<caption id=\"Caption\"><b>Keypress here</b></caption>"
"<colgroup align=left>"
"<colgroup align=center>"
"<colgroup align=right>"
"<tr>"
"<td><BUTTON id=\"Yesterday\" style=\"color: blue\">&LT----</BUTTON></td>"
"<td><b>Day</b></td>"
"<td><BUTTON id=\"Tomorrow\" style=\"color: red\">----&GT</BUTTON></td>"
"</tr>"
"<tr>"
"<td><BUTTON id=\"Last-month\" style=\"color: green\">&LT----</BUTTON></td>"
"<td><b>Month</b></td>"
"<td><BUTTON id=\"Next-month\" style=\"color: indigo\">----&GT</BUTTON></td>"
"</tr>"
"<tr>"
"<td><BUTTON id=\"Last-year\" style=\"color: yellow\">&LT----</BUTTON></td>"
"<td><b>Year</b></td>"
"<td><BUTTON id=\"Next-year\" style=\"color: purple\">----&GT</BUTTON></td>"
"</tr>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"Today\">Today</BUTTON></td>"
"</table>"
"<hr>"
"<table align=center>"
"<tr>"
"<td><BUTTON id=\"Hide\">Hide</BUTTON></td>"
"<td><BUTTON id=\"Show\">Show</BUTTON></td>"
"</tr>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"Rub-me\">Rub me!</BUTTON></td>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"About\">About</BUTTON></td>"
"</table>"
"<table align=center>"
"<td><BUTTON id=\"Quit\">Quit</BUTTON></td>"
"</table>"
"<p>"
"<table align=center>"
"<td id=\"event-reflector\">Click on the calendar</td>"
"</table>"))
(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))

11
collects/syntax/doc.txt
View File

@ -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

14
collects/syntax/modcode.ss
View File

@ -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)