core: Add module indirection for variable lookup.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sun, 14 Oct 2018 06:30:18 +0000 (08:30 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sun, 14 Oct 2018 06:30:18 +0000 (08:30 +0200)
* src/module.c (module_ref, module_variable): New function.
* src/mes.c: Thoughout: Use them.
(assq_ref_env): Remove.
* mes/module/mes/boot-0.scm.in (defined?): Use module-variable.
* mes/module/mes/boot-00.scm (defined?): Likewise.
* mes/module/mes/boot-01.scm (defined?): Likewise.
* mes/module/mes/boot-02.scm (defined?): Likewise.
* scaffold/boot/53-closure-display.scm: Likewise.

mes/module/mes/boot-0.scm.in
mes/module/mes/boot-00.scm
mes/module/mes/boot-01.scm
mes/module/mes/boot-02.scm
scaffold/boot/53-closure-display.scm
scaffold/boot/60-let-syntax-expanded.scm
scaffold/boot/60-let-syntax.scm
src/mes.c
src/module.c

index f4cf991aa089464fca05ed658a5e75bfa8656bd9..07034a24cfdd7a58a3c5867fd96830506c93fec8 100644 (file)
@@ -30,7 +30,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (assq x (current-module)))
+  (module-variable (current-module) x))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))
index 3c43c85c17ee51ef96380884c4d04d897ed8c295..9c85ccb5f9d23ccf836ad75a9b8bf6bb619ef4d4 100644 (file)
@@ -20,7 +20,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (assq x (current-module)))
+  (module-variable (current-module) x))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))
index 086cb00b865b1bd681d3fd21259e80ac1eba6ecc..319d02dcb19e6d0f2dcd6641c297415fcb48e334 100644 (file)
@@ -20,7 +20,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (assq x (current-module)))
+  (module-variable (current-module) x))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))
index b38ec924ee16976e0f41ff64ed6a98d94b1a9c74..0d5217624929526baa96474e6e28f945d73f2f98 100644 (file)
@@ -30,7 +30,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (assq x (current-module)))
+  (module-variable (current-module) x))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))
index e1837c67274d2a303e904c4ec0c05f29e77c64a5..4c31a2217fab63106dccdd8960caf6d3d2a90cd1 100644 (file)
@@ -28,7 +28,7 @@
     (if (null? lst) (list)
         (cons (f (car lst)) (map f (cdr lst)))))
   (define (closure x)
-    (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))))
+    (map car (cdr (core:cdr (core:car (core:cdr (cdr (module-variable (current-module) 'x))))))))))
 
 (define (x t) #t)
 (define (xx x1 x2)
index 4c66e11eca3630a1a3f7fb056ed187408bf7357d..8f84943f0fb17d149b638c709d1c0337675b7d46 100644 (file)
@@ -20,7 +20,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (assq x (current-module)))
+  (module-variable (current-module) x))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))
       (if (eq? x (car lst)) lst
           (memq x (cdr lst)))))
 
-;; (cond-expand
-;;  (guile
-;;   (define closure identity)
-;;   (define body identity)
-;;   (define append2 append)
-;;   (define (core:apply f a m) (f a))
-;;   )
-;;  (mes
   (define <cell:symbol> 11)
   (define (symbol? x)
     (eq? (core:type x) <cell:symbol>))
   (define (vector? x)
     (eq? (core:type x) <cell:vector>))
 
-  ;; (define (body x)
-  ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
-  ;; (define (closure x)
-  ;;   (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
-  ;; ))
-
 (define (cons* . rest)
   (if (null? (cdr rest)) (car rest)
       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
           (append2 (car rest) (apply append (cdr rest))))))
 
 (define-macro (quasiquote x)
-  ;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
   (define (loop x)
-    ;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
     (if (vector? x) (list 'list->vector (loop (vector->list x)))
         (if (not (pair? x)) (cons 'quote (cons x '()))
             (if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
index b6619b68c3db815a0b5d4caa18e88d1151d5d7ad..4710a86aa44ad17aa555f2f07c25d1270bd7d8c2 100644 (file)
       (if (eq? x (car lst)) lst
           (memq x (cdr lst)))))
 
-;; (cond-expand
-;;  (guile
-;;   (define closure identity)
-;;   (define body identity)
-;;   (define append2 append)
-;;   (define (core:apply f a m) (f a))
-;;   )
-;;  (mes
   (define (symbol? x)
     (eq? (core:type x) <cell:symbol>))
 
   (define (vector? x)
     (eq? (core:type x) <cell:vector>))
 
-  ;; (define (body x)
-  ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
-  ;; (define (closure x)
-  ;;   (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
-  ;; ))
-
 (define (cons* . rest)
   (if (null? (cdr rest)) (car rest)
       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
@@ -93,9 +79,7 @@
           (append2 (car rest) (apply append (cdr rest))))))
 
 (define-macro (quasiquote x)
-  ;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
   (define (loop x)
-    ;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
     (if (vector? x) (list 'list->vector (loop (vector->list x)))
         (if (not (pair? x)) (cons 'quote (cons x '()))
             (if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
index ebdb5a27bfd8632c45492cfcf4c39241ea800eac..cd259e63760d664b5067c4145628b55664b358c1 100644 (file)
--- a/src/mes.c
+++ b/src/mes.c
@@ -562,7 +562,7 @@ error (SCM key, SCM x)
 {
 #if !__MESC_MES__
   SCM throw;
-  if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
+  if ((throw = module_ref (r0, cell_symbol_throw)) != cell_undefined)
     return apply (throw, cons (key, cons (x, cell_nil)), r0);
 #endif
   display_error_ (key);
@@ -826,15 +826,6 @@ assq (SCM x, SCM a)
   return a != cell_nil ? CAR (a) : cell_f;
 }
 
-SCM
-assq_ref_env (SCM x, SCM a)
-{
-  x = assq (x, a);
-  if (x == cell_f)
-    return cell_undefined;
-  return CDR (x);
-}
-
 SCM
 set_car_x (SCM x, SCM e)
 {
@@ -860,7 +851,7 @@ set_env_x (SCM x, SCM e, SCM a)
   if (TYPE (x) == TVARIABLE)
     p = VARIABLE (x);
   else
-    p = assert_defined (x, assq (x, a));
+    p = assert_defined (x, module_variable (a, x));
   if (TYPE (p) != TPAIR)
     error (cell_symbol_not_a_pair, cons (p, x));
   return set_cdr_x (p, e);
@@ -1009,7 +1000,7 @@ expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
                    && CAR (x) != cell_symbol_if // HMM
                    && !formal_p (CAR (x), formals))
             {
-              SCM v = assq (CAR (x), r0);
+              SCM v = module_variable (r0, CAR (x));
               if (v != cell_f)
                 CAR (x) = make_variable_ (v);
             }
@@ -1275,7 +1266,7 @@ eval_apply ()
                     }
                   else
                     {
-                      entry = assq (name, r0);
+                      entry = module_variable (r0, name);
                       if (entry == cell_f)
                         {
                           entry = cons (name, cell_f);
@@ -1315,7 +1306,7 @@ eval_apply ()
                 }
               else if (global_p)
                 {
-                  entry = assq (name, r0);
+                  entry = module_variable (r0, name);
                   set_cdr_x (entry, r1);
                 }
               else
@@ -1324,7 +1315,7 @@ eval_apply ()
                   aa = cons (entry, cell_nil);
                   set_cdr_x (aa, cdr (r0));
                   set_cdr_x (r0, aa);
-                  cl = assq (cell_closure, r0);
+                  cl = module_variable (r0, cell_closure);
                   set_cdr_x (cl, aa);
                 }
               r1 = cell_unspecified;
@@ -1350,7 +1341,7 @@ eval_apply ()
           r1 = cell_begin;
           goto vm_return;
         }
-      r1 = assert_defined (r1, assq_ref_env (r1, r0));
+      r1 = assert_defined (r1, module_ref (r0, r1));
       goto vm_return;
     }
   else if (t == TVARIABLE)
@@ -1421,10 +1412,10 @@ eval_apply ()
         && TYPE (CAR (r1)) == TSYMBOL
         && CAR (r1) != cell_symbol_begin
         && ((macro = assq (cell_symbol_portable_macro_expand, g_macros)) != cell_f)
-        && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
+        && ((expanders = module_ref (r0, cell_symbol_sc_expander_alist)) != cell_undefined)
         && ((macro = assq (CAR (r1), expanders)) != cell_f))
       {
-        sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
+        sc_expand = module_ref (r0, cell_symbol_macro_expand);
         r2 = r1;
         if (sc_expand != cell_undefined && sc_expand != cell_f)
           {
index e7f244be633e224c40f16026e0debafda6dbd580..6c1d348961448749f0d669c4b20126879c23c396 100644 (file)
@@ -38,3 +38,20 @@ make_initial_module (SCM a)
   SCM module = make_struct (module_type_name, values, cell_unspecified);
   return module;
 }
+
+SCM
+module_ref (SCM module, SCM name)
+{
+  SCM x = module_variable (module, name);
+  if (x == cell_f)
+    return cell_undefined;
+  return CDR (x);
+}
+
+SCM
+module_variable (SCM module, SCM name)
+{
+  //SCM locals = struct_ref (module, 4);
+  SCM locals = module;
+  return assq (name, locals);
+}