369.10

svn: r6003

original commit: a45251d272

collects/tests/mzscheme/embed-me10.ss

@@ -0,0 +1,9 @@
+(module embed-me10 mzscheme
+  (require (lib "mzssl.ss" "openssl"))
+
+  (with-output-to-file "stdout"
+    (lambda () 
+      (printf "~a\n" ssl-available?))
+    'append))
+
+

collects/tests/mzscheme/embed-me8.c

@@ -0,0 +1,31 @@
+#include "escheme.h"
+
+Scheme_Object *ex(int argc, Scheme_Object **argv)
+{
+  return scheme_make_utf8_string("Hello, world!");
+}
+
+Scheme_Object *scheme_reload(Scheme_Env *env)
+{
+  Scheme_Env *menv;
+
+  menv = scheme_primitive_module(scheme_intern_symbol("embed-me8"),
+				 env);
+
+  scheme_add_global("ex", scheme_make_prim_w_arity(ex, "ex", 0, 0), menv);
+
+  scheme_finish_primitive_module(menv);
+
+  return scheme_void;
+}
+
+Scheme_Object *scheme_initialize(Scheme_Env *env)
+{
+  /* First load is same as every load: */
+  return scheme_reload(env);
+}
+
+Scheme_Object *scheme_module_name()
+{
+  return scheme_intern_symbol("embed-me8");
+}

collects/tests/mzscheme/embed-me9.ss

@@ -0,0 +1,6 @@
+(module embed-me9 mzscheme
+  (require "embed-me8.ss")
+  (with-output-to-file "stdout"
+    (lambda () 
+      (printf "~a\n" (ex)))
+    'append))

collects/tests/mzscheme/embed.ss

@@ -4,33 +4,52 @@
 (Section 'embed)
 
 (require (lib "embed.ss" "compiler")
-	 (lib "process.ss"))
+         (lib "file.ss")
+	 (lib "process.ss")
+         (lib "distribute.ss" "compiler"))
 
-(define (mk-dest mred?)
+(define (mk-dest-bin mred?)
-  (build-path (find-system-path 'temp-dir) 
   (case (system-type)
     [(windows) "e.exe"]
     [(unix) "e"]
     [(macosx) (if mred?
                   "e.app"
-			      "e")])))
+                  "e")]))
+
+(define (mk-dest mred?)
+  (build-path (find-system-path 'temp-dir) 
+              (mk-dest-bin mred?)))
 
 (define mz-dest (mk-dest #f))
 (define mr-dest (mk-dest #t))
 
+(define dist-dir (build-path (find-system-path 'temp-dir)
+                             "e-dist"))
+(define dist-mz-exe (build-path
+                     (case (system-type)
+                       [(windows) 'same]
+                       [else "bin"])
+                     (mk-dest-bin #f)))
+(define dist-mred-exe (build-path
+                       (case (system-type)
+                         [(windows macosx) 'same]
+                         [else "bin"])
+                       (mk-dest-bin #t)))
+
 (define (prepare exe src)
   (printf "Making ~a with ~a...~n" exe src)
   (when (file-exists? exe)
     (delete-file exe)))
 
-(define (try-exe exe expect mred?)
+(define (try-one-exe exe expect mred?)
+  (printf "Running ~a\n" exe)
   (let ([plthome (getenv "PLTHOME")]
 	[collects (getenv "PLTCOLLECTS")])
     ;; Try to hide usual collections:
     (when plthome
-      (putenv "PLTHOME" (path->string (find-system-path 'temp-dir))))
+      (putenv "PLTHOME" (path->string (build-path (find-system-path 'temp-dir) "NOPE"))))
     (when collects
-      (putenv "PLTCOLLECTS" (path->string (find-system-path 'temp-dir))))
+      (putenv "PLTCOLLECTS" (path->string (build-path (find-system-path 'temp-dir) "NOPE"))))
     ;; Execute:
     (parameterize ([current-directory (find-system-path 'temp-dir)])
       (when (file-exists? "stdout")
@@ -47,6 +66,24 @@
     (test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout") 
 	  (lambda () (read-string 5000)))))
 
+(define try-exe 
+  (case-lambda
+   [(exe expect mred?)
+    (try-exe exe expect mred? void)]
+   [(exe expect mred? dist-hook . collects)
+    (try-one-exe exe expect mred?)
+    ;; Build a distirbution directory, and try that, too:
+    (when (directory-exists? dist-dir)
+      (delete-directory/files dist-dir))
+    (assemble-distribution dist-dir (list exe) #:copy-collects collects)
+    (dist-hook)
+    (try-one-exe (build-path dist-dir
+                             (if mred?
+                                 dist-mred-exe
+                                 dist-mz-exe))
+                 expect mred?)
+    (delete-directory/files dist-dir)]))
+
 (define (mz-tests mred?)
   (define dest (if mred? mr-dest mz-dest))
   (define (flags s)
@@ -161,19 +198,22 @@
 (mz-tests #f)
 (mz-tests #t)
 
-(prepare mr-dest "embed-me5.ss")
+(begin
-(make-embedding-executable 
+  (prepare mr-dest "embed-me5.ss")
+  (make-embedding-executable 
    mr-dest #t #f
    `((#t (lib "embed-me5.ss" "tests" "mzscheme")))
    null
    null
    `("-ZmvqL" "embed-me5.ss" "tests/mzscheme"))
-(try-exe mr-dest "This is 5: #<struct:class:button%>\n" #t)
+  (try-exe mr-dest "This is 5: #<struct:class:button%>\n" #t))
 
 ;; Try the mzc interface:
 (require (lib "dirs.ss" "setup")
 	 (lib "file.ss"))
-(define mzc (build-path (find-console-bin-dir) "mzc"))
+(define mzc (build-path (find-console-bin-dir) (if (eq? 'windows (system-type))
+                                                   "mzc.exe"
+                                                   "mzc")))
 
 (define (mzc-tests mred?)
   (parameterize ([current-directory (find-system-path 'temp-dir)])
@@ -206,7 +246,8 @@
 	     "--collects-path"
 	     (path->string (find-collects-dir))
 	     (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
-    (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
+    ;; Don't try a distribution for this one:
+    (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
 
     ;; Try --collects-dest mode
     (system* mzc 
@@ -216,7 +257,7 @@
 	     "--collects-dest" "cts"
 	     "--collects-path" "cts"
 	     (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
-    (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
+    (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution
     (delete-directory/files "cts")
     (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?)
 
@@ -225,7 +266,65 @@
 (mzc-tests #t)
 (mzc-tests #f)
 
-;; One MrEd-specific test with mzc:
+(require (lib "file.ss" "dynext"))
+(define (extension-test mred?)
+  (parameterize ([current-directory (find-system-path 'temp-dir)])
+    
+    (define obj-file
+      (build-path (find-system-path 'temp-dir) (append-object-suffix "embed-me8")))
+
+    (define ext-base-dir
+      (build-path (find-system-path 'temp-dir)
+                  "compiled"))
+
+    (define ext-dir
+      (build-path ext-base-dir
+                  "native"
+                  (system-library-subpath)))
+
+    (define ext-file
+      (build-path ext-dir (append-extension-suffix "embed-me8")))
+
+    (define ss-file
+      (build-path (find-system-path 'temp-dir) "embed-me9.ss"))
+
+    (make-directory* ext-dir)
+    
+    (system* mzc 
+             "--cc"
+             "-d" (path->string (path-only obj-file))
+             (path->string (build-path (collection-path "tests" "mzscheme") "embed-me8.c")))
+    (system* mzc 
+             "--ld"
+             (path->string ext-file)
+             (path->string obj-file))
+
+    (when (file-exists? ss-file)
+      (delete-file ss-file))
+    (copy-file (build-path (collection-path "tests" "mzscheme") "embed-me9.ss")
+               ss-file)
+
+    (system* mzc 
+             (if mred? "--gui-exe" "--exe")
+             (path->string (mk-dest mred?))
+             (path->string ss-file))
+
+    (delete-file ss-file)
+
+    (try-exe (mk-dest mred?) "Hello, world!\n" mred? (lambda ()
+                                                       (delete-directory/files ext-base-dir)))
+
+    ;; openssl, which needs extra binaries under Windows
+    (system* mzc 
+             (if mred? "--gui-exe" "--exe")
+             (path->string (mk-dest mred?))
+             (path->string (build-path (collection-path "tests" "mzscheme") "embed-me10.ss")))
+    (try-exe (mk-dest mred?) "#t\n" mred?)))
+
+(extension-test #f)
+(extension-test #t)
+
+;; A MrEd-specific test with mzc:
 (parameterize ([current-directory (find-system-path 'temp-dir)])
   (system* mzc 
 	   "--gui-exe"
@@ -233,6 +332,19 @@
 	   (path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss")))
   (try-exe (mk-dest #t) "This is 5: #<struct:class:button%>\n" #t))
 
+;; Another MrEd-specific: try embedding plot, which has extra DLLs and font files:
+(parameterize ([current-directory (find-system-path 'temp-dir)])
+  (define direct (build-path (find-system-path 'temp-dir) "direct.ps"))
 
+  (system* (build-path (find-console-bin-dir) "mred")
+           "-qu"
+           (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss"))
+           (path->string direct))
+
+  (system* mzc 
+           "--gui-exe"
+           (path->string (mk-dest #t))
+           (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss")))
+  (try-exe (mk-dest #t) "plotted\n" #t))
 
 (report-errs)