add test for embedding MzScheme and resetting via scheme_basic_env

svn: r11564

collects/tests/mzscheme/benchmarks/common/earley.sch

@@ -647,4 +647,3 @@
       (length (parse->trees x 's 0 k)))))
 
 (time (test 12))
-

collects/tests/mzscheme/embed-in-c.c

@@ -0,0 +1,64 @@
+#include "scheme.h"
+
+static int run(Scheme_Env *e, int argc, char *argv[])
+{
+  Scheme_Object *curout = NULL, *v = NULL, *a[2] = {NULL, NULL};
+  Scheme_Config *config = NULL;
+  int i;
+  mz_jmp_buf * volatile save = NULL, fresh;
+  
+  MZ_GC_DECL_REG(8);
+  MZ_GC_VAR_IN_REG(0, e);
+  MZ_GC_VAR_IN_REG(1, curout);
+  MZ_GC_VAR_IN_REG(2, save);
+  MZ_GC_VAR_IN_REG(3, config);
+  MZ_GC_VAR_IN_REG(4, v);
+  MZ_GC_ARRAY_VAR_IN_REG(5, a, 2);
+  
+  MZ_GC_REG();
+
+  scheme_set_collects_path(scheme_make_path(MZ_COLLECTION_PATH));
+  scheme_init_collection_paths(e, scheme_null);
+
+  v = scheme_intern_symbol("scheme/base");
+  scheme_namespace_require(v);
+  
+  config = scheme_current_config();
+  curout = scheme_get_param(config, MZCONFIG_OUTPUT_PORT);
+  
+  for (i = 1; i < argc; i++) {
+    save = scheme_current_thread->error_buf;
+    scheme_current_thread->error_buf = &fresh;
+    if (scheme_setjmp(scheme_error_buf)) {
+      scheme_current_thread->error_buf = save;
+      return -1; /* There was an error */
+    } else {
+      v = scheme_eval_string(argv[i], e);
+      scheme_display(v, curout);
+      v = scheme_make_char('\n');
+      scheme_display(v, curout);
+    }
+  }
+
+  /* RESET: */
+  e = scheme_basic_env();
+  scheme_init_collection_paths(e, scheme_null);
+  v = scheme_intern_symbol("scheme/base");
+  scheme_namespace_require(v);
+
+  /* read-eval-print loop, uses initial Scheme_Env: */
+  a[0] = scheme_intern_symbol("scheme/base");
+  a[1] = scheme_intern_symbol("read-eval-print-loop");
+  v = scheme_dynamic_require(2, a);
+  scheme_apply(v, 0, NULL);
+  scheme_current_thread->error_buf = save;
+  
+  MZ_GC_UNREG();
+  
+  return 0;
+}
+  
+int main(int argc, char *argv[])
+{
+  return scheme_main_setup(1, run, argc, argv);
+}

collects/tests/mzscheme/embed-in-c.ss

@@ -0,0 +1,47 @@
+;; Works for Linux, Mac OS X.
+;; Assumes 3m
+
+(load-relative "loadtest.ss")
+
+(Section 'embed-in-c)
+
+(require scheme/system
+         setup/dirs)
+
+(define dir (collection-path "tests" "mzscheme"))
+(define lib-dir (find-lib-dir))
+
+(parameterize ([current-directory dir])
+  (test #t system (format "cc -c -o embed-in-c.o -DMZ_COLLECTION_PATH='\"~a\"' -I\"~a\" -DMZ_PRECISE_GC embed-in-c.c"
+                          (find-collects-dir)
+                          (find-include-dir)))
+  
+  (test #t system (format "cc -o embed-in-c embed-in-c.o ~a"
+                          (case (system-type 'link)
+                            [(framework)
+                             (format "-F\"~a\" -framework PLT_MzScheme" lib-dir)]
+                            [(static shared)
+                             (format "-L\"~a\" -lmzscheme3m" lib-dir)]
+                            [else
+                             (error "unsupported")])))
+  
+  (let ([o (open-output-bytes)]
+        [e (open-output-bytes)])
+    (test #t
+          (lambda (s)
+            (parameterize ([current-input-port (open-input-bytes #"5\n(log-error \"ouch!\")")]
+                           [current-output-port o]
+                           [current-error-port e])
+              (system s)))
+          (format "~a./embed-in-c 1 2 3"
+                  (case (system-type 'link)
+                    [(framework)
+                     (format "env DYLD_FRAMEWORK_PATH=\"~a\" " lib-dir)]
+                    [else ""])))
+    (test #"ouch!\n" get-output-bytes e)
+    (test #"1\n2\n3\n> 5\n> > " get-output-bytes o))
+
+  (let ([maybe-delete-file 
+         (lambda (f) (when (file-exists? f) (delete-file f)))])
+    (maybe-delete-file "embed-in-c.o")
+    (maybe-delete-file "embed-in-c")))