From 86d9957ae9a75314e59ee65044de42c86a98dda7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 29 Sep 2013 11:05:54 +0900 Subject: [PATCH] Making sexp_make_primitive_env available from Scheme. Adding the (chibi primitive) module to access this directly. --- eval.c | 2 +- include/chibi/eval.h | 5 ++- lib/meta.scm | 98 ++++++++++++++++++++++++-------------------- opcodes.c | 1 + 4 files changed, 59 insertions(+), 47 deletions(-) diff --git a/eval.c b/eval.c index a20955b3..b4fb86c7 100644 --- a/eval.c +++ b/eval.c @@ -1976,7 +1976,7 @@ sexp sexp_make_null_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) { return e; } -sexp sexp_make_primitive_env (sexp ctx, sexp version) { +sexp sexp_make_primitive_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) { int i; sexp_gc_var4(e, op, sym, name); sexp_gc_preserve4(ctx, e, op, sym, name); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 5417f23c..beb6d79b 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -89,7 +89,7 @@ SEXP_API sexp sexp_exception_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp e SEXP_API sexp sexp_make_env_op (sexp context, sexp self, sexp_sint_t n); SEXP_API sexp sexp_make_null_env_op (sexp context, sexp self, sexp_sint_t n, sexp version); SEXP_API sexp sexp_env_cell_define (sexp ctx, sexp env, sexp name, sexp value, sexp* varenv); -SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); +SEXP_API sexp sexp_make_primitive_env_op (sexp context, sexp self, sexp_sint_t n, sexp version); SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n, sexp version); SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value); SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close); @@ -240,7 +240,8 @@ SEXP_API int sexp_rest_unused_p (sexp lambda); #define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx, NULL, 4, f, n, b, v) #define sexp_make_env(ctx) sexp_make_env_op(ctx, NULL, 0) #define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx, NULL, 0, v) -#define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx, NULL, 0) +#define sexp_make_primitive_env(ctx, v) sexp_make_primitive_env_op(ctx, NULL, 1, v) +#define sexp_make_standard_env(ctx, v) sexp_make_standard_env_op(ctx, NULL, 1, v) #define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx, NULL, 1, d, a) #define sexp_eval(ctx, x, e) sexp_eval_op(ctx, NULL, 2, x, e) #define sexp_load(ctx, f, e) sexp_load_op(ctx, NULL, 2, f, e) diff --git a/lib/meta.scm b/lib/meta.scm index 8c4284e9..7481982e 100644 --- a/lib/meta.scm +++ b/lib/meta.scm @@ -153,46 +153,50 @@ (else (error "couldn't find include" f))))) files)) ;; catch cyclic references - (module-meta-data-set! - mod - `((error "module attempted to reference itself while loading" ,name))) - (for-each - (lambda (x) - (case (and (pair? x) (car x)) - ((import import-immutable) - (for-each - (lambda (m) - (let* ((mod2-name+imports (resolve-import m)) - (mod2 (load-module (car mod2-name+imports)))) - (%import env (module-env mod2) (cdr mod2-name+imports) #t))) - (cdr x))))) - meta) - (protect - (exn (else - (module-meta-data-set! mod meta) - (if (not (any (lambda (x) - (and (pair? x) - (memq (car x) '(import import-immutable)))) - meta)) - (warn "WARNING: exception inside module with no imports - did you forget to (import (scheme base)) in" name)) - (raise-continuable exn))) + (cond + ((procedure? meta) + (meta env)) + (else + (module-meta-data-set! + mod + `((error "module attempted to reference itself while loading" ,name))) (for-each (lambda (x) (case (and (pair? x) (car x)) - ((include) - (load-modules (cdr x) "" #f)) - ((include-ci) - (load-modules (cdr x) "" #t)) - ((include-shared) - (load-modules (cdr x) *shared-object-extension* #f)) - ((body begin) - (for-each (lambda (expr) (eval expr env)) (cdr x))) - ((error) - (apply error (cdr x))))) - meta)) - (module-meta-data-set! mod meta) - (warn-undefs env #f) - env)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%import env (module-env mod2) (cdr mod2-name+imports) #t))) + (cdr x))))) + meta) + (protect + (exn (else + (module-meta-data-set! mod meta) + (if (not (any (lambda (x) + (and (pair? x) + (memq (car x) '(import import-immutable)))) + meta)) + (warn "WARNING: exception inside module with no imports - did you forget to (import (scheme base)) in" name)) + (raise-continuable exn))) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((include) + (load-modules (cdr x) "" #f)) + ((include-ci) + (load-modules (cdr x) "" #t)) + ((include-shared) + (load-modules (cdr x) *shared-object-extension* #f)) + ((body begin) + (for-each (lambda (expr) (eval expr env)) (cdr x))) + ((error) + (apply error (cdr x))))) + meta)) + (module-meta-data-set! mod meta) + (warn-undefs env #f) + env)))) (define (environment . ls) (let ((env (make-environment))) @@ -310,10 +314,16 @@ (error "couldn't find module" (car ls)))))))))))) (define *modules* - (list (cons '(chibi) (make-module #f (interaction-environment) - '((include "init-7.scm")))) - (cons '(scheme) (make-module #f (interaction-environment) '())) - (cons '(meta) (make-module #f (current-environment) '())) - (cons '(srfi 0) (make-module (list 'cond-expand) - (current-environment) - (list (list 'export 'cond-expand)))))) + (list + (cons '(chibi) + (make-module #f (interaction-environment) '((include "init-7.scm")))) + (cons '(chibi primitive) + (make-module #f #f (lambda (env) (primitive-environment 7)))) + (cons '(scheme) + (make-module #f (interaction-environment) '())) + (cons '(meta) + (make-module #f (current-environment) '())) + (cons '(srfi 0) + (make-module (list 'cond-expand) + (current-environment) + (list (list 'export 'cond-expand)))))) diff --git a/opcodes.c b/opcodes.c index b29f8ce4..a752009b 100644 --- a/opcodes.c +++ b/opcodes.c @@ -166,6 +166,7 @@ _FN1(SEXP_VOID, _I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op), _FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), _FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "primitive-environment", 0, sexp_make_primitive_env_op), _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), _FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "compile", (sexp)"interaction-environment", sexp_compile_op), _FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "generate", (sexp)"interaction-environment", sexp_generate_op),