mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
Making sexp_make_primitive_env available from Scheme.
Adding the (chibi primitive) module to access this directly.
This commit is contained in:
Alex Shinn
parent
eb4adcc9dd
commit
86d9957ae9
4 changed files with 59 additions and 47 deletions
2
eval.c
2
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);
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
98
lib/meta.scm
98
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))))))
|
||||
|
|
|
|||
|
|
@ -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),
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue