core: Add module-define!

* src/module.c (module_define_x, module_printer): New function.
(make_initial_module): Use them.
* tests/srfi-0.test: Test it.
* src/mes.c (display_m0): Remove.  Update callers.
* mes/module/mes/fluids.mes (make-fluid): Rewrite.
* tests/macro.test: Test it.
* mes/module/mes/boot-0.scm.in (module-define!): Remove.
* mes/module/mes/boot-02.scm: Likewise.
* module/mes/misc.scm (pk, warn): New function.
* build-aux/check-mes.sh (tests): Run tests.

build-aux/check-mes.sh

@@ -34,6 +34,8 @@ MES_ARENA=${MES_ARENA-100000000}
 tests="
 tests/boot.test
 tests/read.test
+tests/srfi-0.test
+tests/macro.test
 tests/base.test
 tests/quasiquote.test
 tests/let.test

mes/module/mes/boot-0.scm.in

@@ -104,10 +104,6 @@
                             (cons (quote or) (cdr x))))
                 (car x)))))
 
-(define-macro (module-define! module name value)
-  ;;(list 'define name value)
-  #t)
-
 (define-macro (mes-use-module module)
   #t)
 ;; end boot-02.scm

mes/module/mes/boot-02.scm

@@ -104,10 +104,6 @@
                             (cons (quote or) (cdr x))))
                 (car x)))))
 
-(define-macro (module-define! module name value)
-  ;;(list 'define name value)
-  #t)
-
 (define-macro (mes-use-module module)
   #t)
 

mes/module/mes/fluids.mes

@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; GNU Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Mes.
 ;;;
@@ -24,39 +24,19 @@
 
 (mes-use-module (mes scm))
 
-
-(define (sexp:define e a)
-  (if (atom? (car (cdr e))) (cons (car (cdr e))
-                                  (core:eval (car (cdr (cdr e))) a))
-      (cons (car (car (cdr e)))
-            (core:eval (cons (quote lambda)
-                             (cons (cdr (car (cdr e))) (cdr (cdr e)))) a))))
-
-(define (f:env:define a+ a)
-  (set-cdr! a+ (cdr a))
-  (set-cdr! a a+)
-  ;;(set-cdr! (assq '*closure* a) a+)
-  )
-
-(define (env:escape-closure a n)
-  (if (eq? (caar a) '*closure*) (if (= 0 n) a
-                                    (env:escape-closure (cdr a) (- n 1)))
-      (env:escape-closure (cdr a) n)))
-
-(define-macro (module-define! name value a)
-  `(f:env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a 1)))
-
 (define-macro (make-fluid . default)
-  `(begin
+  ((lambda (fluid)
-     ,(let ((fluid (symbol-append 'fluid: (gensym)))
+     `(begin
-            (module (current-module)))
+        (module-define!
-        `(begin
+         (boot-module)
-           (module-define! ,fluid
+        ',fluid
-                           (let ((v ,(and (pair? default) (car default))))
+        ((lambda (v)
-                             (lambda ( . rest)
+           (lambda ( . rest)
-                               (if (null? rest) v
+             (if (null? rest) v
-                                   (set! v (car rest))))) ',module)
+                 (set! v (car rest)))))
-           ',fluid))))
+         ,(and (pair? default) (car default))))
+        ',fluid))
+   (symbol-append 'fluid: (gensym))))
 
 (define (fluid-ref fluid)
   (fluid))

module/mes/misc.scm

@@ -22,7 +22,9 @@
             disjoin
             guile?
             mes?
+            pk
             pke
+            warn
             stderr
             string-substitute))
 
@@ -43,6 +45,13 @@
 (define (stderr string . rest)
   (apply logf (cons* (current-error-port) string rest)))
 
+(define (pk . stuff)
+  (newline)
+  (display ";;; ")
+  (write stuff)
+  (newline)
+  (car (last-pair stuff)))
+
 (define (pke . stuff)
   (newline (current-error-port))
   (display ";;; " (current-error-port))
@@ -50,6 +59,8 @@
   (newline (current-error-port))
   (car (last-pair stuff)))
 
+(define warn pke)
+
 (define (disjoin . predicates)
   (lambda (. arguments)
     (any (lambda (o) (apply o arguments)) predicates)))

src/mes.c

@@ -52,6 +52,8 @@ SCM r1 = 0;
 SCM r2 = 0;
 // continuation
 SCM r3 = 0;
+// current-module
+SCM m0 = 0;
 // macro
 SCM g_macros = 1;
 SCM g_ports = 1;
@@ -662,7 +664,7 @@ check_apply (SCM f, SCM e) ///((internal))
 SCM
 gc_push_frame () ///((internal))
 {
-  SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
+  SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cons (m0, cell_nil)))));
   g_stack = cons (frame, g_stack);
   return g_stack;
 }
@@ -897,7 +899,10 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
   r2 = p2;
   gc_push_frame ();
   r1 = p1;
-  r0 = a;
+  // if (TYPE (a) == TPAIR)
+  //   r0 = module_clone_locals (r0, a);
+  // else
+    r0 = a;
   r3 = x;
   return cell_unspecified;
 }
@@ -910,6 +915,7 @@ gc_peek_frame () ///((internal))
   r2 = CADR (frame);
   r3 = CAR (CDDR (frame));
   r0 = CADR (CDDR (frame));
+  m0 = CAR (CDDR (CDDR (frame)));
   return frame;
 }
 
@@ -1017,6 +1023,9 @@ expand_variable (SCM x, SCM formals) ///((internal))
   return expand_variable_ (x, formals, 1);
 }
 
+SCM struct_ref_ (SCM x, long i);
+SCM vector_ref_ (SCM x, long i);
+
 SCM
 eval_apply ()
 {
@@ -1268,12 +1277,7 @@ eval_apply ()
                     {
                       entry = module_variable (r0, name);
                       if (entry == cell_f)
-                        {
+                        module_define_x (m0, name, cell_f);
-                          entry = cons (name, cell_f);
-                          aa = cons (entry, cell_nil);
-                          set_cdr_x (aa, cdr (r0));
-                          set_cdr_x (r0, aa);
-                        }
                     }
                 }
               r2 = r1;
@@ -1507,6 +1511,8 @@ eval_apply ()
 
               push_cc (input, r2, r0, cell_vm_return);
               x = read_input_file_env (r0);
+              if (g_debug > 3)
+                module_printer (m0);
               gc_pop_frame ();
               input = r1;
               r1 = x;
@@ -1594,12 +1600,12 @@ apply (SCM f, SCM x, SCM a) ///((internal))
 SCM
 mes_g_stack (SCM a) ///((internal))
 {
-  r0 = a;
+  //r0 = a;
   r1 = MAKE_CHAR (0);
   r2 = MAKE_CHAR (0);
   r3 = MAKE_CHAR (0);
   g_stack = cons (cell_nil, cell_nil);
-  return r0;
+  return a;
 }
 
 // Environment setup
@@ -2025,20 +2031,6 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
 
-  char *compiler = "gnuc";
-#if __MESC__
-  compiler = "mesc";
-#elif __TINYC__
-  compiler = "tcc";
-#endif
-  a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a);
-
-  char *arch = "x86";
-#if __x86_64__
-  arch = "x86_64";
-#endif
-  a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
-
   a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
   a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
   a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
@@ -2064,9 +2056,31 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
 }
 
 SCM
-mes_environment () ///((internal))
+mes_environment (int argc, char *argv[])
 {
   SCM a = mes_symbols ();
+
+  char *compiler = "gnuc";
+#if __MESC__
+  compiler = "mesc";
+#elif __TINYC__
+  compiler = "tcc";
+#endif
+  a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a);
+
+  char *arch = "x86";
+#if __x86_64__
+  arch = "x86_64";
+#endif
+  a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
+
+#if !MES_MINI
+  SCM lst = cell_nil;
+  for (int i=argc-1; i>=0; i--)
+    lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
+  a = acons (cell_symbol_argv, lst, a);
+#endif
+
   return mes_g_stack (a);
 }
 
@@ -2287,9 +2301,8 @@ load_boot (char *prefix, char const *boot, char const *location)
 }
 
 SCM
-load_env (SCM a) ///((internal))
+load_env () ///((internal))
 {
-  r0 = a;
   g_stdin = -1;
   char prefix[1024];
   char boot[1024];
@@ -2328,15 +2341,13 @@ load_env (SCM a) ///((internal))
       exit (1);
     }
 
-  if (!g_function)
-    r0 = mes_builtins (r0);
   r2 = read_input_file_env (r0);
   g_stdin = STDIN;
   return r2;
 }
 
 SCM
-bload_env (SCM a) ///((internal))
+bload_env () ///((internal))
 {
 #if !_POSIX_SOURCE
   char *mo = "mes/boot-0.32-mo";
@@ -2376,23 +2387,11 @@ bload_env (SCM a) ///((internal))
   gc_peek_frame ();
   g_symbols = r1;
   g_stdin = STDIN;
+  // SCM a = struct_ref (r0, 3);
+  // a = mes_builtins (a);
+  // struct_set_x (r0, 3, a);
   r0 = mes_builtins (r0);
 
-  char *compiler = "gnuc";
-#if __MESC__
-  compiler = "mesc";
-#elif __TINYC__
-  compiler = "tcc";
-#endif
-
-  a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a);
-
-  char *arch = "x86";
-#if __x86_64__
-  arch = "x86_64";
-#endif
-  a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
-
   if (g_debug > 3)
     {
       eputs ("symbols: ");
@@ -2448,21 +2447,20 @@ main (int argc, char *argv[])
     GC_SAFETY = atoi (p);
   g_stdin = STDIN;
   g_stdout = STDOUT;
-  r0 = mes_environment ();
+
+  SCM a = mes_environment (argc, argv);
+  a = mes_builtins (a);
+  m0 = make_initial_module (a);
+
+  if (g_debug > 3)
+    module_printer (m0);
 
   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
-    ? bload_env (r0) : load_env (r0);
+    ? bload_env () : load_env ();
   g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
   if (argc > 1 && !strcmp (argv[1], "--dump"))
     return dump ();
 
-#if !MES_MINI
-  SCM lst = cell_nil;
-  for (int i=argc-1; i>=0; i--)
-    lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
-  r0 = acons (cell_symbol_argv, lst, r0); // FIXME
-  r0 = acons (cell_symbol_argv, lst, r0);
-#endif
   push_cc (r2, cell_unspecified, r0, cell_unspecified);
 
   if (g_debug > 2)

src/module.c

@@ -18,8 +18,14 @@
  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+SCM make_vector__ (long k);
+SCM struct_ref_ (SCM x, long i);
+SCM struct_set_x_ (SCM x, long i, SCM e);
+SCM vector_ref_ (SCM x, long i);
+SCM vector_set_x_ (SCM x, long i, SCM e);
+
 SCM
-make_initial_module (SCM a)
+make_initial_module (SCM a) ///((internal))
 {
   SCM fields = cell_nil;
   fields = cons (cstring_to_symbol ("globals"), fields);
@@ -31,17 +37,105 @@ make_initial_module (SCM a)
   a = acons (module_type_name, module_type, a);
   SCM values = cell_nil;
   SCM name = cons (cstring_to_symbol ("boot"), cell_nil);
-  SCM globals = cell_nil;
+  //SCM globals = make_vector__ (28 * 27);
-  values = cons (a, values);
+  SCM globals = make_vector__ (30 * 27);
   values = cons (globals, values);
+  SCM locals = cell_nil;
+  values = cons (locals, values);
   values = cons (name, values);
-  SCM module = make_struct (module_type_name, values, cell_unspecified);
+  SCM module = make_struct (module_type_name, values, cell_module_printer);
+  r0 = cell_nil;
+  r0 = cons (CAR (a), r0);
+
+  m0 = module;
+  while (TYPE (a) == TPAIR)
+    {
+      if (g_debug > 3)
+        {
+          eputs ("entry="); display_error_ (CAR (a)); eputs ("\n");
+        }
+      module_define_x (module, CAAR (a), CDAR (a));
+      a = CDR (a);
+    }
+
   return module;
 }
 
+SCM
+module_printer (SCM module)
+{
+  eputs ("#<"); display_error_ (struct_ref_ (module, 0)); eputc (' ');
+  //eputs ("printer: "); display_error_ (struct_ref_ (module, 1)); eputc (' ');
+  eputs ("name: "); display_error_ (struct_ref_ (module, 2)); eputc (' ');
+  eputs ("locals: "); display_error_ (struct_ref_ (module, 3)); eputc (' ');
+  eputs ("globals:\n  ");
+  SCM v = struct_ref_ (m0, 4);
+  for (int i=0; i<LENGTH (v); i++)
+    {
+      SCM e = vector_ref_ (v, i);
+      if (e != cell_unspecified)
+        {
+          eputc ('[');
+          while (TYPE (e) == TPAIR)
+            {
+              display_error_ (CAAR (e));
+              e = CDR (e);
+              if (TYPE (e) == TPAIR)
+                eputc (' ');
+            }
+          eputs ("]\n  ");
+        }
+    }
+  eputc ('>');
+}
+
+
+
+int
+char_hash (int c)
+{
+  if (c >= 'a' && c <= 'z')
+    return c - 'a';
+  return 27;
+}
+
+int
+module_hash (SCM x) ///((internal))
+{
+  int hash = char_hash (VALUE (CAR (STRING (x)))) * 27;
+  if (TYPE (CDR (STRING (x))) == TPAIR)
+    hash = hash + char_hash (VALUE (CADR (STRING (x))));
+  else
+    hash = hash + char_hash (0);
+  assert (hash <= 756);
+  return hash;
+}
+
+SCM
+module_variable (SCM module, SCM name)
+{
+  //SCM locals = struct_ref_ (module, 3);
+  SCM locals = module;
+  SCM x = assq (name, locals);
+  if (x == cell_f)
+    {
+      int hash = module_hash (name);
+      module = m0;
+      SCM globals = struct_ref_ (module, 4);
+      SCM bucket = vector_ref_ (globals, hash);
+      if (TYPE (bucket) == TPAIR)
+        x = assq (name, bucket);
+    }
+  return x;
+}
+
 SCM
 module_ref (SCM module, SCM name)
 {
+  if (g_debug > 4)
+    {
+      eputs ("module_ref: "); display_error_ (name); eputs ("\n");
+    }
   SCM x = module_variable (module, name);
   if (x == cell_f)
     return cell_undefined;
@@ -49,9 +143,19 @@ module_ref (SCM module, SCM name)
 }
 
 SCM
-module_variable (SCM module, SCM name)
+module_define_x (SCM module, SCM name, SCM value)
 {
-  //SCM locals = struct_ref (module, 4);
+  if (g_debug > 4)
-  SCM locals = module;
+    {
-  return assq (name, locals);
+      eputs ("module_define_x: "); display_error_ (name); eputs ("\n");
+    }
+  int hash = module_hash (name);
+  module = m0;
+  SCM globals = struct_ref_ (module, 4);
+  SCM bucket = vector_ref_ (globals, hash);
+  if (TYPE (bucket) != TPAIR)
+    bucket = cell_nil;
+  bucket = acons (name, value, bucket);
+  vector_set_x_ (globals, hash, bucket);
+  return cell_t;
 }

src/reader.c

@@ -34,8 +34,9 @@ read_input_file_env_ (SCM e, SCM a)
 SCM
 read_input_file_env (SCM a)
 {
-  r0 = a;
+  //r0 = a;
-  return read_input_file_env_ (read_env (r0), r0);
+  //return read_input_file_env_ (read_env (r0), r0);
+  return read_input_file_env_ (read_env (cell_nil), cell_nil);
 }
 
 int

src/struct.c

@@ -47,11 +47,11 @@ struct_length (SCM x)
 }
 
 SCM
-struct_ref (SCM x, SCM i)
+struct_ref_ (SCM x, long i)
 {
   assert (TYPE (x) == TSTRUCT);
-  assert (VALUE (i) < LENGTH (x));
+  assert (i < LENGTH (x));
-  SCM e = STRUCT (x) + VALUE (i);
+  SCM e = STRUCT (x) + i;
   if (TYPE (e) == TREF)
     e = REF (e);
   if (TYPE (e) == TCHAR)
@@ -62,10 +62,22 @@ struct_ref (SCM x, SCM i)
 }
 
 SCM
-struct_set_x (SCM x, SCM i, SCM e)
+struct_set_x_ (SCM x, long i, SCM e)
 {
   assert (TYPE (x) == TSTRUCT);
   assert (VALUE (i) < LENGTH (x));
-  g_cells[STRUCT (x)+VALUE (i)] = g_cells[vector_entry (e)];
+  g_cells[STRUCT (x)+i] = g_cells[vector_entry (e)];
   return cell_unspecified;
 }
+
+SCM
+struct_ref (SCM x, SCM i)
+{
+  return struct_ref_ (x, VALUE (i));
+}
+
+SCM
+struct_set_x (SCM x, SCM i, SCM e)
+{
+  return struct_set_x_ (x, VALUE (i), e);
+}

src/vector.c

@@ -42,11 +42,11 @@ vector_length (SCM x)
 }
 
 SCM
-vector_ref (SCM x, SCM i)
+vector_ref_ (SCM x, long i)
 {
   assert (TYPE (x) == TVECTOR);
-  assert (VALUE (i) < LENGTH (x));
+  assert (i < LENGTH (x));
-  SCM e = VECTOR (x) + VALUE (i);
+  SCM e = VECTOR (x) + i;
   if (TYPE (e) == TREF)
     e = REF (e);
   if (TYPE (e) == TCHAR)
@@ -56,6 +56,12 @@ vector_ref (SCM x, SCM i)
   return e;
 }
 
+SCM
+vector_ref (SCM x, SCM i)
+{
+  return vector_ref_ (x, VALUE (i));
+}
+
 SCM
 vector_entry (SCM x)
 {
@@ -65,14 +71,20 @@ vector_entry (SCM x)
 }
 
 SCM
-vector_set_x (SCM x, SCM i, SCM e)
+vector_set_x_ (SCM x, long i, SCM e)
 {
   assert (TYPE (x) == TVECTOR);
-  assert (VALUE (i) < LENGTH (x));
+  assert (i < LENGTH (x));
-  g_cells[VECTOR (x)+VALUE (i)] = g_cells[vector_entry (e)];
+  g_cells[VECTOR (x)+i] = g_cells[vector_entry (e)];
   return cell_unspecified;
 }
 
+SCM
+vector_set_x (SCM x, SCM i, SCM e)
+{
+  return vector_set_x_ (x, VALUE (i), e);
+}
+
 SCM
 list_to_vector (SCM x)
 {

tests/guile.test

@@ -26,11 +26,13 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 (define-module (tests guile)
   #:use-module (ice-9 rdelim)
   #:use-module (mes mes-0)
+  #:use-module (mes misc)
   #:use-module (mes test))
 
 (cond-expand
  (mes
   (mes-use-module (mes test))
+  (mes-use-module (mes misc))
   (mes-use-module (mes guile)))
  (else))
 
@@ -71,14 +73,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 	  (set-current-input-port (car ipstk))
 	  (fluid-set! *input-stack* (cdr ipstk))))))
 
-;; Return #f if empty
-(define (pop-input)
-  (let ((ipstk (fluid-ref *input-stack*)))
-    (if (null? ipstk) #f
-	(begin
-	  (set-current-input-port (car ipstk))
-	  (fluid-set! *input-stack* (cdr ipstk))))))
-
 (pass-if-equal "push-input"
     "bla"
   (let ()
@@ -102,8 +96,7 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
             (unless (eof-object? ch) (write-char ch) (iter (read-char))))
           (pop-input)
           (let iter ((ch (read-char)))
-            (unless (eof-object? ch) (write-char ch) (iter (read-char))))
+            (unless (eof-object? ch) (write-char ch) (iter (read-char)))))))))
-          )))))
 
 (pass-if "input-stack/2"
   (let ((sp (open-input-string "abc")))

tests/macro.test

@@ -0,0 +1,119 @@
+#! /bin/sh
+# -*-scheme-*-
+if [ "$MES" != guile ]; then
+    export MES_BOOT=boot-02.scm
+    MES=${MES-$(dirname $0)/../src/mes}
+    $MES < $0
+    exit $?
+else
+    exit 0
+fi
+exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macro)' -s "$0" "$@"
+!#
+
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of GNU Mes.
+;;;
+;;; GNU Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests boot)
+  #:use-module (mes mes-0)
+  #:use-module (mes test))
+
+(cond-expand
+ (mes
+  (primitive-load "module/mes/test.scm"))
+ (guile-2)
+ (guile
+  (use-modules (ice-9 syncase))))
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(define gensym
+  ((lambda (symbols)
+     (lambda (. rest)
+       ((lambda (head tail)
+          (set! symbols tail)
+          head)
+        (car symbols)
+        (cdr symbols))))
+   '(g0 g1 g2 g3 g4)))
+
+;; type-0.mes
+(define (string . lst)
+  (core:make-cell <cell:string> lst 0))
+
+(define (string->symbol s)
+  (if (not (pair? (core:car s))) '()
+      (list->symbol (core:car s))))
+
+(define (symbol->list s)
+  (core:car s))
+
+;; boot-0.scm
+(define (symbol->string s)
+  (apply string (symbol->list s)))
+
+(define (string-append . rest)
+  (apply string (apply append (map1 string->list rest))))
+
+;; scm.mes
+(define (symbol-append . rest)
+  (string->symbol (apply string-append (map symbol->string rest))))
+
+(define-macro (make-fluid . default)
+  ((lambda (fluid)
+     (list
+      'begin
+      (list
+       'module-define!
+       (list 'boot-module)
+       (list 'quote fluid)
+       (list
+        (lambda (v)
+          (lambda ( . rest)
+            (if (null? rest) v
+                (set! v (car rest)))))
+        (and (pair? default) (car default))))
+      (list 'quote fluid)))
+   (symbol-append 'fluid: (gensym))))
+
+(define fluid (make-fluid 42))
+
+(pass-if-eq "fluid" 42 (fluid))
+
+(fluid 0)
+(pass-if-eq "fluid 0" 0 (fluid))
+
+(fluid '())
+(pass-if-eq "fluid null" '() (fluid))
+
+(define (fluid-ref fluid)
+  (fluid))
+
+(define (fluid-set! fluid value)
+  (fluid value))
+
+(fluid-set! fluid 0)
+(pass-if-eq "fluid 0" 0 (fluid-ref fluid))
+
+(fluid-set! fluid '())
+(pass-if-eq "fluid null" '() (fluid-ref fluid))
+
+(result 'report)

tests/srfi-0.test

@@ -0,0 +1,48 @@
+#! /bin/sh
+# -*-scheme-*-
+if [ "$MES" != guile ]; then
+    export MES_BOOT=boot-02.scm
+    MES=${MES-$(dirname $0)/../src/mes}
+    $MES < $0
+    exit $?
+fi
+exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
+!#
+
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of GNU Mes.
+;;;
+;;; GNU Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests srfi-0)
+  #:use-module (mes mes-0)
+  #:use-module (mes test))
+
+(display "srfi-0...\n")
+
+(cond-expand
+ (mes
+  (display "mes\n")
+  (exit 0))
+ (guile
+  (display "guile\n")
+  (exit guile?))
+ (else
+  (exit 1)))
+
+(exit 1)