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

svn: r6012

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

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

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"))
+(module mxdemo mzscheme
-(require (lib "mysterx.ss" "mysterx"))
   
-; the browser with the calendar
+  (require (lib "class.ss"))
+  (require (lib "mysterx.ss" "mysterx"))
   
-(define calwb (instantiate mx-browser% 
+  (require (lib "runtime-path.ss")
-			   () ; no by-position initializers
+           (lib "system.ss"))
-			   (label "Calendar control")
+  ;; Ensure that DLLs are included with the distibution:
-			   (height 400)
+  (define-runtime-path myspage-dll (so "myspage"))
-			   (width 350)
+  (define-runtime-path myssink-dll (so "myssink"))
-			   (y 100)
+  ;; Register them every time we start:
-			   (x 100)
+  (system* "regsvr32.exe" "/s" myspage-dll)
-			   (style-options '(scrollbars))))
+  (system* "regsvr32.exe" "/s" myssink-dll)
 
-(define caldoc (send calwb current-document))
+  ; the browser with the calendar
   
-(send caldoc insert-html 
+  (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>"
@@ -28,167 +42,173 @@
 	 "<p>"
 	 "<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	
-	"<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>"
+         "</table>"
          
-	"<td><BUTTON id=\"Rub-me\">Rub me!</BUTTON></td>"
+         "<table align=center>"
+         "<td><BUTTON id=\"About\">About</BUTTON></td>"
+         "</table>"
          
-	"</table>"
+         "<table align=center>"
+         "<td><BUTTON id=\"Quit\">Quit</BUTTON></td>"
+         "</table>"
          
-	"<table align=center>"
+         "<p>"
          
-	"<td><BUTTON id=\"About\">About</BUTTON></td>"
+         "<table align=center>"
          
-	"</table>"
+         "<td id=\"event-reflector\">Click on the calendar</td>"
          
-	"<p>"
+         "</table>"))
   
-	"<table align=center>"
+  (define reflector (send ctrldoc find-element "TD" "event-reflector"))
   
-	"<td id=\"event-reflector\">Click on the calendar</td>"
+  (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)))))
   
-	"</table>"))
+  (define (quit-handler ev)
+    (when (send ev click?)
+      (exit)))
   
-(define reflector (send ctrldoc find-element "TD" "event-reflector"))
+  (define (about-handler ev)
+    (when (send ev click?)
+      (com-invoke cal "AboutBox")))
   
-(com-register-event-handler 
+  (define (hide-handler ev)
- cal "Click" 
+    (when (send ev click?)
- (lambda ()
+      (send calwb show #f)))
-   (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)
+  (define (show-handler ev)
-  (when (send ev click?)
+    (when (send ev click?)
-	(com-invoke cal "AboutBox")))
+      (send calwb show #t)))
   
-(define (hide-handler ev)
+  (define rub-me-handler
-  (when (send ev click?)
+    (let ([count 0])
-	(send calwb show #f)))
+      (lambda (ev)
+        (when (send ev mousemove?)
+          (printf "mousemove #~a, but who's counting?~n" count)
+          (set! count (add1 count))))))
   
-(define (show-handler ev)
+  (define (today-handler ev)
-  (when (send ev click?)
+    (when (send ev click?)
-	(send calwb show #t)))
+      (com-invoke cal "Today")))
   
-(define rub-me-handler
+  (define (yesterday-handler ev)
-  (let ([count 0])
+    (when (send ev click?)
-    (lambda (ev)
+      (com-invoke cal "PreviousDay")))
-      (when (send ev mousemove?)
-	    (printf "mousemove #~a, but who's counting?~n" count)
-	    (set! count (add1 count))))))
   
-(define (today-handler ev)
+  (define (tomorrow-handler ev)
-  (when (send ev click?)
+    (when (send ev click?)
-	(com-invoke cal "Today")))
+      (com-invoke cal "NextDay")))
   
-(define (yesterday-handler ev)
+  (define (last-month-handler ev)
-  (when (send ev click?)
+    (when (send ev click?)
-	(com-invoke cal "PreviousDay")))
+      (com-invoke cal "PreviousMonth")))
   
-(define (tomorrow-handler ev)
+  (define (next-month-handler ev)
-  (when (send ev click?)
+    (when (send ev click?)
-	(com-invoke cal "NextDay")))
+      (com-invoke cal "NextMonth")))
   
-(define (last-month-handler ev)
+  (define (last-year-handler ev)
-  (when (send ev click?)
+    (when (send ev click?)
-	(com-invoke cal "PreviousMonth")))
+      (com-invoke cal "PreviousYear")))
   
-(define (next-month-handler ev)
+  (define (next-year-handler ev)
-  (when (send ev click?)
+    (when (send ev click?)
-	(com-invoke cal "NextMonth")))
+      (com-invoke cal "NextYear")))
   
-(define (last-year-handler ev)
+  (define button-handlers
-  (when (send ev click?)
+    `(("Quit" ,quit-handler)
-	(com-invoke cal "PreviousYear")))
+      ("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)))
   
-(define (next-year-handler ev)
+  (send ctrlwb register-event-handler
-  (when (send ev click?)
+        (send ctrldoc find-element "CAPTION" "Caption")
-	(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")
 	(lambda (ev)
 	  (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))

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

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
+          ;; 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
              (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)