Making sexp_make_primitive_env available from Scheme.

Adding the (chibi primitive) module to access this directly.

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);

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)

lib/meta.scm

@@ -153,46 +153,50 @@
             (else (error "couldn't find include" f)))))
        files))
     ;; catch cyclic references
-    (module-meta-data-set!
+    (cond
-     mod
+     ((procedure? meta)
-     `((error "module attempted to reference itself while loading" ,name)))
+      (meta env))
-    (for-each
+     (else
-     (lambda (x)
+      (module-meta-data-set!
-       (case (and (pair? x) (car x))
+       mod
-         ((import import-immutable)
+       `((error "module attempted to reference itself while loading" ,name)))
-          (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)
+           ((import import-immutable)
-            (load-modules (cdr x) "" #f))
+            (for-each
-           ((include-ci)
+             (lambda (m)
-            (load-modules (cdr x) "" #t))
+               (let* ((mod2-name+imports (resolve-import m))
-           ((include-shared)
+                      (mod2 (load-module (car mod2-name+imports))))
-            (load-modules (cdr x) *shared-object-extension* #f))
+                 (%import env (module-env mod2) (cdr mod2-name+imports) #t)))
-           ((body begin)
+             (cdr x)))))
-            (for-each (lambda (expr) (eval expr env)) (cdr x)))
+       meta)
-           ((error)
+      (protect
-            (apply error (cdr x)))))
+          (exn (else
-       meta))
+                (module-meta-data-set! mod meta)
-    (module-meta-data-set! mod meta)
+                (if (not (any (lambda (x)
-    (warn-undefs env #f)
+                                (and (pair? x)
-    env))
+                                     (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)
+  (list
-                                    '((include "init-7.scm"))))
+   (cons '(chibi)
-        (cons '(scheme) (make-module #f (interaction-environment) '()))
+         (make-module #f (interaction-environment) '((include "init-7.scm"))))
-        (cons '(meta) (make-module #f (current-environment) '()))
+   (cons '(chibi primitive)
-        (cons '(srfi 0) (make-module (list 'cond-expand)
+         (make-module #f #f (lambda (env) (primitive-environment 7))))
-                                     (current-environment)
+   (cons '(scheme)
-                                     (list (list 'export 'cond-expand))))))
+         (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))))))

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),