From fb1ee7d8cfa47932324104f5cf022af4339179a3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 7 Sep 2008 12:41:20 +0000 Subject: [PATCH] add test for embedding MzScheme and resetting via scheme_basic_env svn: r11564 --- .../mzscheme/benchmarks/common/earley.sch | 1 - collects/tests/mzscheme/embed-in-c.c | 64 +++++++++++++++++++ collects/tests/mzscheme/embed-in-c.ss | 47 ++++++++++++++ 3 files changed, 111 insertions(+), 1 deletion(-) create mode 100644 collects/tests/mzscheme/embed-in-c.c create mode 100644 collects/tests/mzscheme/embed-in-c.ss diff --git a/collects/tests/mzscheme/benchmarks/common/earley.sch b/collects/tests/mzscheme/benchmarks/common/earley.sch index da885155e5..d5f90a238a 100644 --- a/collects/tests/mzscheme/benchmarks/common/earley.sch +++ b/collects/tests/mzscheme/benchmarks/common/earley.sch @@ -647,4 +647,3 @@ (length (parse->trees x 's 0 k))))) (time (test 12)) - diff --git a/collects/tests/mzscheme/embed-in-c.c b/collects/tests/mzscheme/embed-in-c.c new file mode 100644 index 0000000000..9bc2c4c264 --- /dev/null +++ b/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); +} diff --git a/collects/tests/mzscheme/embed-in-c.ss b/collects/tests/mzscheme/embed-in-c.ss new file mode 100644 index 0000000000..10543bb04e --- /dev/null +++ b/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")))