Revert "gash: WIP"

This reverts commit fc31c2b8d79d78d47260b96201894bc00fc6a60b.

AUTHORS

@@ -18,6 +18,13 @@ scaffold/tests/98-fopen.c
 Han-Wen Nienhuys <hanwen@xs4all.nl>
 lib/string/memmem.c (_memmem, memmem)
 
+Peter de Wachter
+Small fixes and additions to
+lib/x86-mes/x86.M1
+lib/x86_64-mes/x86_64.M1
+include/stdint.h
+module/mescc/compile.mes
+
 rain1
 scaffold/tests/90-goto-var.c
 scaffold/tests/91-goto-array.c

NEWS

@@ -10,6 +10,54 @@ Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 
 Please send Mes bug reports to bug-mes@gnu.org.
 
+* Changes in 0.19 since 0.18
+** Core
+*** Mes now prints a backtrace upon error.
+*** Performance has been improved 2-8 times, making Mes 2-10 times slower than Guile.
+*** Mes now supports a module type and uses a `boot-module'.
+*** Mes now supports a hash_table type.
+*** Mes now supports a struct type.
+*** Mes now supports building a %bootstrap-mes seed from Guix.
+** Language
+*** Records are now implemented using struct (WAS: vector).
+*** 30 new functions
+ceil,
+current-time,
+floor,
+frame-printer,
+get-internal-run-time,
+gettimeofday,
+hash,
+hash-ref,
+hash-set!,
+hash-table-printer,
+hashq,
+hashq-get-handle,
+hashq-ref,
+hashq-set,
+inexact->exact,
+make-hash-table,
+make-stack,
+make-struct,
+module-define!
+module-printer,
+module-ref,
+module-variable,
+round,
+stack-length,
+stack-ref,
+struct-ref,
+struct-set!
+struct-vtable,
+struct-vtable,
+struct_length.
+** MesCC
+*** Assembly defines have been cleaned-up: duplicates deleted, missing added, wrong fixed.
+** Noteworthy bug fixes
+*** MesCC now supports the unary plus operator.
+*** MesCC now supports the `U' integer suffix.
+*** MesCC now comes with INTnn_MIN/MAX, UINTnn defines in stdint.h.
+*** MesCC now always exits non-zero when assembler or linker fail.
 * Changes in 0.18 since 0.17.1
 ** Core
 *** Mes/MesCC now supports x86_64.

build-aux/build-cc.sh

@@ -24,13 +24,7 @@ set -e
 . ${srcdest}build-aux/trace.sh
 
 # native
-trace "SNARF      gc.c"     ${srcdest}build-aux/mes-snarf.scm src/gc.c
-trace "SNARF      lib.c"    ${srcdest}build-aux/mes-snarf.scm src/lib.c
-trace "SNARF      math.c"   ${srcdest}build-aux/mes-snarf.scm src/math.c
-trace "SNARF      mes.c"    ${srcdest}build-aux/mes-snarf.scm src/mes.c
-trace "SNARF      posix.c"  ${srcdest}build-aux/mes-snarf.scm src/posix.c
-trace "SNARF      reader.c" ${srcdest}build-aux/mes-snarf.scm src/reader.c
-trace "SNARF      vector.c" ${srcdest}build-aux/mes-snarf.scm src/vector.c
+sh ${srcdest}build-aux/snarf.sh
 
 ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc.sh lib/libmes
 sh ${srcdest}build-aux/cc.sh src/mes

build-aux/build-cc32.sh

@@ -27,23 +27,7 @@ LIBC=${LIBC-c}
 
 ##moduledir=${moduledir-${datadir}${datadir:+/}module}
 
-# native
-# trace "SNARF      gc.c"     ${srcdest}build-aux/mes-snarf.scm src/gc.c
-# trace "SNARF      lib.c"    ${srcdest}build-aux/mes-snarf.scm src/lib.c
-# trace "SNARF      math.c"   ${srcdest}build-aux/mes-snarf.scm src/math.c
-# trace "SNARF      mes.c"    ${srcdest}build-aux/mes-snarf.scm src/mes.c
-# trace "SNARF      posix.c"  ${srcdest}build-aux/mes-snarf.scm src/posix.c
-# trace "SNARF      reader.c" ${srcdest}build-aux/mes-snarf.scm src/reader.c
-# trace "SNARF      vector.c" ${srcdest}build-aux/mes-snarf.scm src/vector.c
-
-# cc32-mes
-trace "SNARF.mes  gc.c"     ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
-trace "SNARF.mes  lib.c"    ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
-trace "SNARF.mes  math.c"   ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
-trace "SNARF.mes  mes.c"    ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
-trace "SNARF.mes  posix.c"  ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
-trace "SNARF.mes  reader.c" ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
-trace "SNARF.mes  vector.c" ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
+sh ${srcdest}build-aux/snarf.sh --mes
 
 ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc32-mes.sh lib/linux/x86-mes-gcc/crt0
 ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc32-mes.sh lib/linux/x86-mes-gcc/crt1

build-aux/build-cc64.sh

@@ -26,13 +26,7 @@ set -e
 LIBC=${LIBC-c}
 
 # cc64-mes
-trace "SNARF.mes  gc.c"     ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
-trace "SNARF.mes  lib.c"    ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
-trace "SNARF.mes  math.c"   ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
-trace "SNARF.mes  mes.c"    ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
-trace "SNARF.mes  posix.c"  ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
-trace "SNARF.mes  reader.c" ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
-trace "SNARF.mes  vector.c" ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
+sh ${srcdest}build-aux/snarf.sh --mes
 
 ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc64-mes.sh lib/linux/x86_64-mes-gcc/crt0
 ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc64-mes.sh lib/linux/x86_64-mes-gcc/crt1

build-aux/build-mes.sh

@@ -128,13 +128,7 @@ ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-mes.sh lib/libc+gnu
 ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-mes.sh lib/libgetopt
 
 MES_ARENA=${MES_ARENA-100000000}
-trace "SNARF.mes  gc.c"     ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
-trace "SNARF.mes  lib.c"    ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
-trace "SNARF.mes  math.c"   ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
-trace "SNARF.mes  mes.c"    ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
-trace "SNARF.mes  posix.c"  ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
-trace "SNARF.mes  reader.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
-trace "SNARF.mes  vector.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
+sh ${srcdest}build-aux/snarf.sh --mes
 
 if [ -n "$SEED" ]; then
     bash ${srcdest}build-aux/cc-mes.sh src/mes

build-aux/build-x86_64-mes.sh

@@ -123,13 +123,7 @@ ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-x86_64-mes.sh lib/libc+gnu
 ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-x86_64-mes.sh lib/libgetopt
 
 MES_ARENA=${MES_ARENA-100000000}
-trace "SNARF.mes  gc.c"     ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
-trace "SNARF.mes  lib.c"    ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
-trace "SNARF.mes  math.c"   ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
-trace "SNARF.mes  mes.c"    ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
-trace "SNARF.mes  posix.c"  ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
-trace "SNARF.mes  reader.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
-trace "SNARF.mes  vector.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
+sh ${srcdest}build-aux/snarf.sh --mes
 
 if [ -n "$SEED" ]; then
     bash ${srcdest}build-aux/cc-mes.sh src/mes

build-aux/check-mes.sh

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

build-aux/check-mescc.sh

@@ -219,6 +219,7 @@ t
 97-fopen
 98-fopen
 99-readdir
+9a-snprintf
 a0-call-trunc-char
 a0-call-trunc-short
 a0-call-trunc-int

build-aux/mes-snarf.scm

@@ -146,8 +146,8 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
        (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (function.name f) (function.name f))
        (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f)))
    (if %gcc?
-       (format #f "a = acons (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
-       (format #f "a = acons (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
+       (format #f "a = acons (list_to_symbol (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
+       (format #f "a = acons (list_to_symbol (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
 
 (define (disjoin . predicates)
   (lambda (. arguments)

build-aux/snarf.sh

@@ -0,0 +1,39 @@
+#! /bin/sh
+
+# 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/>.
+
+set -e
+
+. ${srcdest}build-aux/config.sh
+. ${srcdest}build-aux/trace.sh
+
+snarf="    "
+if [ -n "$1" ]; then
+    snarf=.mes
+fi
+trace "SNARF$snarf  gc.c"     ${srcdest}build-aux/mes-snarf.scm $1 src/gc.c
+trace "SNARF$snarf  hash.c"   ${srcdest}build-aux/mes-snarf.scm $1 src/hash.c
+trace "SNARF$snarf  lib.c"    ${srcdest}build-aux/mes-snarf.scm $1 src/lib.c
+trace "SNARF$snarf  math.c"   ${srcdest}build-aux/mes-snarf.scm $1 src/math.c
+trace "SNARF$snarf  mes.c"    ${srcdest}build-aux/mes-snarf.scm $1 src/mes.c
+trace "SNARF$snarf  module.c" ${srcdest}build-aux/mes-snarf.scm $1 src/module.c
+trace "SNARF$snarf  posix.c"  ${srcdest}build-aux/mes-snarf.scm $1 src/posix.c
+trace "SNARF$snarf  reader.c" ${srcdest}build-aux/mes-snarf.scm $1 src/reader.c
+trace "SNARF$snarf  struct.c" ${srcdest}build-aux/mes-snarf.scm $1 src/struct.c
+trace "SNARF$snarf  vector.c" ${srcdest}build-aux/mes-snarf.scm $1 src/vector.c

doc/mes.texi

@@ -33,7 +33,7 @@ Documentation License''.
 @end direntry
 
 @titlepage
-@title Mes Reference Manual
+@title GNU Mes Reference Manual
 @subtitle Full Source Bootstrapping of the GNU GuixSD Operating System
 @author Jan (janneke) Nieuwenhuizen
 
@@ -49,7 +49,7 @@ Edition @value{EDITION} @*
 
 @c *********************************************************************
 @node Top
-@top Mes
+@top GNU Mes
 
 This document describes GNU Mes version @value{VERSION}, a bootstrappable
 Scheme interpreter and C compiler written for bootstrapping the GNU system.
@@ -1039,7 +1039,7 @@ Please send bug reports with full details to @email{bug-mes@@gnu.org}.
 @chapter Acknowledgments
 
 We would like to thank the following people for their help: Jeremiah
-Orians, pdewacht, rain1, Ricardo Wurmus, Rutger van Beusekom.
+Orians, Peter de Wachter, rain1, Ricardo Wurmus, Rutger van Beusekom.
 
 We also thank Ludovic Courtès for creating GuixSD and making the
 bootstrap problem so painfully visible, John McCarthy for creating

include/libmes.h

@@ -43,6 +43,7 @@ int isspace (int c);
 int isxdigit (int c);
 int _open3 (char const *file_name, int flags, int mask);
 int _open2 (char const *file_name, int flags);
+int oputc (int c);
 int oputs (char const* s);
 ssize_t write (int filedes, void const *buffer, size_t size);
 char *search_path (char const *file_name);

include/limits.h

@@ -29,19 +29,12 @@
 
 #else // ! WITH_GLIBC
 
-#define CHAR_BIT 8
-#define UCHAR_MAX 255
-#define CHAR_MAX 255
-#define UINT_MAX 4294967295U
-#define ULONG_MAX 4294967295U
-#define INT_MIN -2147483648
-#define INT_MAX 2147483647
+#include <stdint.h>
+
 #define MB_CUR_MAX 1
-#define LONG_MIN -2147483648
-#define LONG_MAX 2147483647
-#define _POSIX_OPEN_MAX 16
-#define PATH_MAX 512
 #define NAME_MAX 255
+#define PATH_MAX 512
+#define _POSIX_OPEN_MAX 16
 
 #endif // ! WITH_GLIBC
 

include/stdint.h

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
  * Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018 Peter De Wachter <pdewacht@gmail.com>
  *
  * This file is part of GNU Mes.
  *
@@ -80,6 +81,40 @@ typedef unsigned* uintptr_t;
 typedef long ptrdiff_t;
 #endif
 
+#define CHAR_BIT 8
+#define CHAR_MAX 255
+#define UCHAR_MAX 255
+
+#define INT8_MAX 127
+#define INT8_MIN (-INT8_MAX-1)
+#define UINT8_MAX 255
+
+#define INT16_MAX 32767
+#define INT16_MIN (-INT16_MAX-1)
+#define UINT16_MAX 65535
+
+#define INT32_MAX 2147483647
+#define INT32_MIN (-INT32_MAX-1)
+#define UINT32_MAX 4294967295U
+
+#define INT64_MAX 9223372036854775807LL
+#define INT64_MIN (-INT64_MAX-1)
+#define UINT64_MAX 18446744073709551615ULL
+
+#define INT_MIN -2147483648
+#define INT_MAX 2147483647
+#if __i386__
+#define LONG_MIN INT_MIN
+#define LONG_MAX INT_MAX
+#define UINT_MAX UINT32_MAX
+#define ULONG_MAX UINT32_MAX
+#elif __x86_64__
+#define LONG_MIN INT64_MIN
+#define LONG_MAX INT64_MAX
+#define UINT_MAX UINT32_MAX
+#define ULONG_MAX UINT64_MAX
+#endif
+
 #endif // ! WITH_GLIBC
 
 #endif // __MES_STDINT_H

include/time.h

@@ -54,6 +54,7 @@ struct timespec
 
 #endif // __MES_STRUCT_TIMESPEC
 
+#define CLOCK_PROCESS_CPUTIME_ID 2
 int clock_gettime (clockid_t clk_id, struct timespec *tp);
 struct tm *localtime (time_t const *timep);
 struct tm *gmtime (time_t const *time);

lib/libmes.c

@@ -47,3 +47,4 @@
 #endif // POSIX
 
 #include <mes/eputc.c>
+#include <mes/oputc.c>

lib/linux/clock_gettime.c

@@ -0,0 +1,27 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+#include <time.h>
+
+int
+clock_gettime (clockid_t clk_id, struct timespec *tp)
+{
+  return _sys_call2 (SYS_clock_gettime, (long)clk_id, (long)tp);
+}

lib/linux/gettimeofday.c

@@ -0,0 +1,27 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+#include <time.h>
+
+int
+gettimeofday (struct timeval *tv, struct timezone *tz)
+{
+  return _sys_call2 (SYS_gettimeofday, (long)tv, (long)tz);
+}

lib/linux/gnu.c

@@ -173,9 +173,3 @@ chdir (char const *file_name)
 {
   return _sys_call1 (SYS_chdir, (long)file_name);
 }
-
-int
-clock_gettime (clockid_t clk_id, struct timespec *tp)
-{
-  return _sys_call2 (SYS_clock_gettime, (long)clk_id, (long)tp);
-}

lib/linux/libc.c

@@ -149,3 +149,7 @@ fsync (int filedes)
 {
   return _sys_call1 (SYS_fsync, (int)filedes);
 }
+
+#include "linux/clock_gettime.c"
+#include "linux/gettimeofday.c"
+#include "linux/time.c"

lib/linux/tcc.c

@@ -60,15 +60,3 @@ getcwd (char *buffer, size_t size)
 {
   return _sys_call2 (SYS_getcwd, (long)buffer, (long)size);
 }
-
-time_t
-time (time_t *result)
-{
-  return _sys_call1 (SYS_time, (long)result);
-}
-
-int
-gettimeofday (struct timeval *tv, struct timezone *tz)
-{
-  return _sys_call2 (SYS_gettimeofday, (long)tv, (long)tz);
-}

lib/linux/time.c

@@ -0,0 +1,27 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+#include <time.h>
+
+time_t
+time (time_t *result)
+{
+  return _sys_call1 (SYS_time, (long)result);
+}

lib/mes/oputc.c

@@ -0,0 +1,27 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+#include <libmes.h>
+
+int
+oputc (int c)
+{
+  return fdputc (c, STDOUT);
+}

lib/stdio/snprintf.c

@@ -25,8 +25,14 @@ int
 snprintf (char *str,  size_t size,  char const *format, ...)
 {
   va_list ap;
+  int r;
+#if __GNUC__ && __x86_64__
+#define __FUNCTION_ARGS 3
+  ap += (__FOO_VARARGS + (__FUNCTION_ARGS << 1)) << 3;
+#undef __FUNCTION_ARGS
+#endif
   va_start (ap, format);
-  int r = vsprintf (str, format, ap);
+  r = vsnprintf (str, size, format, ap);
   va_end (ap);
   return r;
 }

lib/stdio/vsnprintf.c

@@ -22,7 +22,200 @@
 #include <stdlib.h>
 
 int
-vsnprintf (char *str, size_t size, char const *format, va_list ap)
+vsnprintf (char *str, size_t size, char const* format, va_list ap)
 {
-  return vsprintf (str, format, ap);
+  char const *p = format;
+  int count = 0;
+  char c;
+  while (*p)
+    if (*p != '%')
+      {
+        c = *p++;
+        if (count < size)
+          *str++ = c;
+        count++;
+      }
+    else
+      {
+        p++;
+        c = *p;
+        int left_p = 0;
+        int precision = -1;
+        int width = -1;
+        if (c == '-')
+          {
+            left_p = 1;
+            c = *++p;
+          }
+        char pad = ' ';
+        if (c == '0')
+          {
+            pad = c;
+            c = *p++;
+          }
+        if (c >= '0' && c <= '9')
+          {
+            width = abtol (&p, 10);
+            c = *p;
+          }
+        else if (c == '*')
+          {
+            width = va_arg (ap, long);
+            c = *++p;
+          }
+        if (c == '.')
+          {
+            c = *++p;
+            if (c >= '0' && c <= '9')
+              {
+                precision = abtol (&p, 10);
+                c = *p;
+              }
+            else if (c == '*')
+              {
+                precision = va_arg (ap, long);
+                c = *++p;
+              }
+          }
+        if (c == 'l')
+          c = *++p;
+        if (c == 'l')
+          c = *++p;
+        if (c == 'l')
+          {
+            eputs ("vsnprintf: skipping second: l\n");
+            c = *++p;
+          }
+        switch (c)
+          {
+          case '%':
+            {
+              if (count < size)
+                *str++ = *p;
+              count++;
+              break;
+            }
+          case 'c':
+            {
+              c = va_arg (ap, long);
+              if (count < size)
+                *str++ = c;
+              count++;
+              break;
+            }
+          case 'd':
+          case 'i':
+          case 'o':
+          case 'u':
+          case 'x':
+          case 'X':
+            {
+              long d = va_arg (ap, long);
+              int base = c == 'o' ? 8
+                : c == 'x' || c == 'X' ? 16
+                : 10;
+              char const *s = ntoab (d, base, c != 'u' && c != 'x' && c != 'X');
+              if (c == 'X')
+                strupr (s);
+              int length = strlen (s);
+              if (precision == -1)
+                precision = length;
+              if (!left_p)
+                {
+                  while (width-- > precision)
+                    {
+                      if (count < size)
+                        *str++ = pad;
+                      count++;
+                    }
+                  while (precision > length)
+                    {
+                      if (count < size)
+                        *str++ = '0';
+                      precision--;
+                      width--;
+                      count++;
+                    }
+                }
+              while (*s)
+                {
+                  if (precision-- <= 0)
+                    break;
+                  width--;
+                  c = *s++;
+                  if (count < size)
+                    *str++ = c;
+                  count++;
+                }
+              while (width > 0)
+                {
+                  width--;
+                  if (count < size)
+                    *str++ = pad;
+                  count++;
+                }
+              break;
+            }
+          case 's':
+            {
+              char *s = va_arg (ap, char *);
+              int length = s ? strlen (s) : 0;
+              if (precision == -1)
+                precision = length;
+              if (!left_p)
+                {
+                  while (width-- > precision)
+                    {
+                      if (count < size)
+                        *str++ = pad;
+                      count++;
+                    }
+                  while (width > length)
+                    {
+                      if (count < size)
+                        *str++ = ' ';
+                      precision--;
+                      width--;
+                      count++;
+                    }
+                }
+              while (s && *s)
+                {
+                  if (precision-- <= 0)
+                    break;
+                  width--;
+                  c = *s++;
+                  if (count < size)
+                    *str++ = c;
+                  count++;
+                }
+              while (width > 0)
+                {
+                  width--;
+                  if (count < size)
+                    *str++ = pad;
+                  count++;
+                }
+              break;
+            }
+          case 'n':
+            {
+              int *n = va_arg (ap, int *);
+              *n = count;
+              break;
+            }
+          default:
+            {
+              eputs ("vsnprintf: not supported: %:");
+              eputc (c);
+              eputs ("\n");
+              p++;
+            }
+          }
+        p++;
+      }
+  va_end (ap);
+  if (count < size)
+    *str = 0;
+  return count;
 }

lib/stdio/vsprintf.c

@@ -24,182 +24,5 @@
 int
 vsprintf (char *str, char const* format, va_list ap)
 {
-  char const *p = format;
-  int count = 0;
-  while (*p)
-    if (*p != '%')
-      {
-        *str++ = *p++;
-        count++;
-      }
-    else
-      {
-        p++;
-        char c = *p;
-        int left_p = 0;
-        int precision = -1;
-        int width = -1;
-        if (c == '-')
-          {
-            left_p = 1;
-            c = *++p;
-          }
-        char pad = ' ';
-        if (c == '0')
-          {
-            pad = c;
-            c = *p++;
-          }
-        if (c >= '0' && c <= '9')
-          {
-            width = abtol (&p, 10);
-            c = *p;
-          }
-        else if (c == '*')
-          {
-            width = va_arg (ap, long);
-            c = *++p;
-          }
-        if (c == '.')
-          {
-            c = *++p;
-            if (c >= '0' && c <= '9')
-              {
-                precision = abtol (&p, 10);
-                c = *p;
-              }
-            else if (c == '*')
-              {
-                precision = va_arg (ap, long);
-                c = *++p;
-              }
-          }
-        if (c == 'l')
-          c = *++p;
-        if (c == 'l')
-          c = *++p;
-        if (c == 'l')
-          {
-            eputs ("vfprintf: skipping second: l\n");
-            c = *++p;
-          }
-        switch (c)
-          {
-          case '%':
-            {
-              *str++ = *p;
-              count++;
-              break;
-            }
-          case 'c':
-            {
-              c = va_arg (ap, long);
-              *str++ = c;
-              count++;
-              break;
-            }
-          case 'd':
-          case 'i':
-          case 'o':
-          case 'u':
-          case 'x':
-          case 'X':
-            {
-              long d = va_arg (ap, long);
-              int base = c == 'o' ? 8
-                : c == 'x' || c == 'X' ? 16
-                : 10;
-              char const *s = ntoab (d, base, c != 'u' && c != 'x' && c != 'X');
-              if (c == 'X')
-                strupr (s);
-              int length = strlen (s);
-              if (precision == -1)
-                precision = length;
-              if (!left_p)
-                {
-                  while (width-- > precision)
-                    {
-                      *str++ = pad;
-                      count++;
-                    }
-                  while (precision > length)
-                    {
-                      *str++ = '0';
-                      precision--;
-                      width--;
-                      count++;
-                    }
-                }
-              while (*s)
-                {
-                  if (precision-- <= 0)
-                    break;
-                  width--;
-                  *str++ = *s++;
-                  count++;
-                }
-              while (width > 0)
-                {
-                  width--;
-                  *str++ = pad;
-                  count++;
-                }
-              break;
-            }
-          case 's':
-            {
-              char *s = va_arg (ap, char *);
-              int length = strlen (s);
-              if (precision == -1)
-                precision = length;
-              if (!left_p)
-                {
-                  while (width-- > precision)
-                    {
-                      *str++ = pad;
-                      count++;
-                    }
-                  while (width > length)
-                    {
-                      *str++ = ' ';
-                      precision--;
-                      width--;
-                      count++;
-                    }
-                }
-              while (*s)
-                {
-                  if (precision-- <= 0)
-                    break;
-                  width--;
-                  *str++ = *s++;
-                  count++;
-                }
-              while (width > 0)
-                {
-                  width--;
-                  *str++ = pad;
-                  count++;
-                }
-              break;
-            }
-          case 'n':
-            {
-              int *n = va_arg (ap, int *);
-              *n = count;
-              break;
-            }
-          default:
-            {
-              eputs ("vsprintf: not supported: %:");
-              eputc (c);
-              eputs ("\n");
-              p++;
-            }
-          }
-        p++;
-      }
-  va_end (ap);
-  *str = 0;
-  return strlen (str);
+  return vsnprintf (str, LONG_MAX, format, ap);
 }

lib/x86-mes/x86.M1

@@ -129,14 +129,15 @@ DEFINE mov____0x8(%ebp),%edx 8b55
 DEFINE mov____0x8(%ebp),%esi 8b75
 DEFINE mov____0x8(%ebp),%esp 8b65
 DEFINE movb___%al,0x32 a2
+DEFINE movb___%bl,0x32 881d
 DEFINE movsbl_%al,%eax 0fbec0
 DEFINE movsbl_%bl,%ebx 0fbedb
 DEFINE movswl_%ax,%eax 0fbfc0
 DEFINE movswl_%bx,%ebx 0fbfdb
 DEFINE movw___%ax,0x32 66a3
+DEFINE movw___%bx,0x32 66891d
 DEFINE movzbl_%al,%eax 0fb6c0
 DEFINE movzbl_%bl,%ebx 0fb6db
-DEFINE movzbl_%bl,%ebx 0fb6db
 DEFINE movzbl_(%eax),%eax 0fb600
 DEFINE movzbl_(%ebx),%ebx 0fb61b
 DEFINE movzbl_0x32(%eax),%eax 0fb680
@@ -203,7 +204,6 @@ DEFINE test___%eax,%eax 85c0
 DEFINE test___%ebx,%ebx 85db
 DEFINE xchg___%eax,%ebx 93
 DEFINE xchg___%eax,(%esp) 870424
-DEFINE xchg___%eax,(%esp) 870424
 DEFINE xchg___%ebx,(%esp) 871c24
 DEFINE xor____$i32,%eax 35
 DEFINE xor____$i8,%ah 80f4

lib/x86_64-mes/x86_64.M1

@@ -1,5 +1,6 @@
 ### GNU Mes --- Maxwell Equations of Software
 ### Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+### Copyright © 2018 Peter De Wachter <pdewacht@gmail.com>
 ###
 ### This file is part of GNU Mes.
 ###
@@ -54,6 +55,7 @@ DEFINE call___*%rax ffd0
 DEFINE call___*%rdi ffd7
 DEFINE cmp____$i32,%rax 483d
 DEFINE cmp____$i8,%rax 4883f8
+DEFINE cmp____$i8,%rdi 4883ff
 DEFINE cmp____%r15,%rax 4c39f8
 DEFINE cmp____%r15,%rdi 4c39ff
 DEFINE cqto 4899
@@ -78,8 +80,6 @@ DEFINE mov____$i32,%rax 48c7c0
 DEFINE mov____$i32,%rdi 48c7c7
 DEFINE mov____$i32,0x8(%rbp) c745
 DEFINE mov____$i64,%r15 49bf
-DEFINE mov____$i64,%rax 48a1
-DEFINE mov____$i64,%rax 48b8
 DEFINE mov____$i64,%rax 48b8
 DEFINE mov____$i64,%rdi 48bf
 DEFINE mov____%al,(%rdi) 8807
@@ -92,7 +92,6 @@ DEFINE mov____%eax,%rax 89c0
 DEFINE mov____%eax,(%rdi) 8907
 DEFINE mov____%eax,0x32(%rbp)  8985
 DEFINE mov____%eax,0x8(%rbp) 8945
-DEFINE mov____%eax,0x8(%rbp) 8945
 DEFINE mov____%edi,%edi 89ff
 DEFINE mov____%edi,%rdi 89ff
 DEFINE mov____%edi,0x32(%rbp) 89bd

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

@@ -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)))
@@ -42,7 +42,6 @@
 ;; end boot-00.scm
 
 ;; boot-01.scm
-(define (pair? x) (eq? (core:type x) <cell:pair>))
 (define (not x) (if x #f #t))
 
 (define (display x . rest)
@@ -104,10 +103,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-00.scm

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

mes/module/mes/boot-01.scm

@@ -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)))
@@ -32,7 +32,6 @@
 ;; end boot-00.scm
 
 ;; boot-01.scm
-(define (pair? x) (eq? (core:type x) <cell:pair>))
 (define (not x) (if x #f #t))
 
 (define (display x . rest)

mes/module/mes/boot-02.scm

@@ -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)))
@@ -42,7 +42,6 @@
 ;; end boot-00.scm
 
 ;; boot-01.scm
-(define (pair? x) (eq? (core:type x) <cell:pair>))
 (define (not x) (if x #f #t))
 
 (define (display x . rest)
@@ -104,10 +103,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/catch.mes

@@ -31,6 +31,8 @@
                      (core:display-error ":")
                      (core:write-error args)
                      (core:display-error "\n")))
+               (core:display-error "Backtrace:\n")
+               (display-backtrace (make-stack) (current-error-port))
                (exit 1))))
 
 (define (catch key thunk handler)
@@ -54,3 +56,16 @@
     (apply handler (cons key args))))
 
 (define with-throw-handler catch) ; FIXME: hack for Nyacc 0.75
+
+(define (frame-procedure frame)
+  (struct-ref frame 3))
+
+(define (display-backtrace stack port . rest)
+  (let* ((frames (map (lambda (i) (stack-ref stack i)) (iota (stack-length stack))))
+         (call-frames (filter frame-procedure frames))
+         (display-frames (drop-right call-frames 2)))
+    (for-each (lambda (f)
+                (core:display-error "  ")
+                (core:display-error f)
+                (core:display-error "\n"))
+              display-frames)))

mes/module/mes/display.mes

@@ -115,6 +115,7 @@
        ((port? x)
         (display "#<port " port)
         (display (core:cdr x) port)
+        (display " ")
         (display (core:car x) port)
         (display ">" port))
        ((variable? x)
@@ -142,6 +143,13 @@
         (if (keyword? x) (display "#:" port))
         (for-each (display-cut2 display-char <> port write?) (string->list x))
         (if (and (string? x) write?) (write-char #\" port)))
+       ((struct? x)
+        (display "#<" port)
+        (for-each (lambda (i)
+                    (let ((x (strut-ref x i)))
+                      (d x #f (if (= i 0) "" " "))))
+                  (iota (struct-length x)))
+        (display ")" port))
        ((vector? x)
         (display "#(" port)
         (for-each (lambda (i)
@@ -214,7 +222,7 @@
                     ((#\s) (write (car args) port))
                     (else (display (car args) port)))
                   (simple-format (cddr lst) (cdr args)))))))
-    
+
     (if destination (simple-format lst rest)
         (with-output-to-string
           (lambda () (simple-format lst rest))))))

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
-     ,(let ((fluid (symbol-append 'fluid: (gensym)))
-            (module (current-module)))
-        `(begin
-           (module-define! ,fluid
-                           (let ((v ,(and (pair? default) (car default))))
-                             (lambda ( . rest)
-                               (if (null? rest) v
-                                   (set! v (car rest))))) ',module)
-           ',fluid))))
+  ((lambda (fluid)
+     `(begin
+        (module-define!
+         (boot-module)
+        ',fluid
+        ((lambda (v)
+           (lambda ( . rest)
+             (if (null? rest) v
+                 (set! v (car rest)))))
+         ,(and (pair? default) (car default))))
+        ',fluid))
+   (symbol-append 'fluid: (gensym))))
 
 (define (fluid-ref fluid)
   (fluid))
@@ -92,7 +72,7 @@
     `(let ,(map (lambda (b s) `(,s (,b))) (map car bindings) syms)
        ,@(map (lambda (o) `(fluid-set! ,(car o) ,(cadr o))) bindings)
        (let ((r (begin ,@bodies)))
-         `,@(map (lambda (b s) `(fluid-set! ,b ,s)) (map car bindings) syms)
+         ,@(map (lambda (b s) `(fluid-set! ,b ,s)) (map car bindings) syms)
          r))))
 
 (define (dynamic-wind in-guard thunk out-guard)

mes/module/mes/guile.mes

@@ -31,16 +31,6 @@
 (mes-use-module (srfi srfi-16))
 (mes-use-module (mes display))
 
-(if #t ;;(not (defined? 'read-string))
-    (define (read-string)
-      (define (read-string c)
-        (if (eq? c #\*eof*) '()
-            (cons c (read-string (read-char)))))
-      (let ((string (list->string (read-string (read-char)))))
-        (if (and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 3)) string->number))
-            (core:display-error (string-append "drained: `" string "'\n")))
-        string)))
-
 (define (drain-input port) (read-string))
 
 (define (make-string n . fill)

mes/module/mes/posix.mes

@@ -57,3 +57,6 @@
 (define (waitpid pid . options)
   (let ((options (if (null? options) 0 (car options))))
     (core:waitpid pid options)))
+
+(define (status:exit-val status)
+  (ash status -8))

mes/module/mes/scm.mes

@@ -108,11 +108,6 @@
 (define assv assq)
 (define assv-ref assq-ref)
 
-(define (assoc key alist)
-  (if (not (pair? alist)) #f
-      (if (equal? key (caar alist)) (car alist)
-          (assoc key (cdr alist)))))
-
 (define (assoc-ref alist key)
   (let ((entry (assoc key alist)))
     (if entry (cdr entry)
@@ -373,6 +368,12 @@
   (lambda args
     (not (apply proc args))))
 
+(define ceil identity)
+(define floor identity)
+(define round identity)
+(define inexact->exact identity)
+(define exact->inexact identity)
+
 (define (const . rest)
   (lambda (. _)
     (car rest)))

mes/module/mes/type-0.mes

@@ -37,6 +37,7 @@
         (cons <cell:ref> (quote <cell:ref>))
         (cons <cell:special> (quote <cell:special>))
         (cons <cell:string> (quote <cell:string>))
+        (cons <cell:struct> (quote <cell:struct>))
         (cons <cell:symbol> (quote <cell:symbol>))
         (cons <cell:values> (quote <cell:values>))
         (cons <cell:variable> (quote <cell:variable>))
@@ -74,9 +75,6 @@
 (define (number? x)
   (eq? (core:type x) <cell:number>))
 
-(define (pair? x)
-  (eq? (core:type x) <cell:pair>))
-
 (define (port? x)
   (eq? (core:type x) <cell:port>))
 
@@ -86,6 +84,9 @@
 (define (string? x)
   (eq? (core:type x) <cell:string>))
 
+(define (struct? x)
+  (eq? (core:type x) <cell:struct>))
+
 (define (symbol? x)
   (eq? (core:type x) <cell:symbol>))
 
@@ -119,14 +120,11 @@
 
 (define (string->symbol s)
   (if (not (pair? (core:car s))) '()
-      (core:lookup-symbol (core:car s))))
+      (list->symbol (core:car s))))
 
 (define (symbol->keyword s)
   (core:make-cell <cell:keyword> (symbol->list s) 0))
 
-(define (list->symbol lst)
-  (core:lookup-symbol lst))
-
 (define (symbol->list s)
   (core:car s))
 

mes/module/srfi/srfi-9-struct.mes

@@ -0,0 +1,145 @@
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2017,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/>.
+
+;;; Commentary:
+
+;;; srfi-9.mes - records, based on struct.
+
+(define-macro (define-record-type name constructor+params predicate . fields)
+  (let ((type (make-record-type name (map car fields))))
+   `(begin
+      (define ,name ,type)
+      (define ,(car constructor+params) ,(record-constructor type name (cdr constructor+params)))
+      (define ,predicate ,(record-predicate type))
+      (define-record-accessors ,type ,@fields))))
+
+(define (make-record-type type fields . printer)
+  (let ((printer (if (pair? printer) (car printer))))
+    (make-struct '<record-type> (cons type (list fields)) printer)))
+
+(define (record-type? o)
+  (eq? (struct-vtable o) '<record-type>))
+
+(define (struct-vtable o)
+  (struct-ref o 0))
+
+(define (record-type o)
+  (struct-ref o 2))
+
+(define (record-predicate type)
+  (lambda (o)
+    (and (record? o)
+         (eq? (record-type o) (record-type type)))))
+
+(define (record? o)
+  (and (struct? o)
+       (record-type? (struct-vtable o))))
+
+(define (record-constructor type name params)
+  (let ((fields (record-fields type))
+        (record-type (record-type type)))
+    (lambda (. o)
+      (if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
+          (let ((rest (make-list (- (length fields) (length params)))))
+            (make-struct type (cons name (append o rest)) record-printer))))))
+
+(define record-printer *unspecified*)   ; TODO
+(define (record-printer o)
+  (display "#<")
+  (display (record-type o))
+  (let* ((vtable (struct-vtable o))
+         (fields (record-fields vtable)))
+    (for-each (lambda (field)
+                (display " ")
+                (display field)
+                (display ": ")
+                (display ((record-getter vtable field) o)))
+              fields))
+  (display ">"))
+
+(define (record-fields o)
+  (struct-ref o 3))
+
+(define-macro (define-record-accessors type . fields)
+  `(begin
+     ,@(map (lambda (field)
+              `(define-record-accessor ,type ,field))
+            fields)))
+
+(define-macro (define-record-accessor type field)
+  `(begin
+     (define ,(cadr field) ,(record-getter type (car field)))
+     (if ,(pair? (cddr field))
+         (define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
+
+(define (record-getter type field)
+  (let ((i (record-field-index type field)))
+    (lambda (o . field?)
+      (if (not (eq? (record-type o) (record-type type))) (error "record getter: record expected" type o)
+          (if (pair? field?) field
+              (struct-ref o i))))))
+
+(define (record-setter type field)
+  (let ((i (record-field-index type field)))
+    (lambda (o v)
+      (if (not (eq? (record-type o) (record-type type))) (error "record setter: record expected" type o)
+          (struct-set! o i v)))))
+
+(define (record-field-index type field)
+  (+ 3 (or (lst-index (record-fields type) field)
+           (error "no such field" type field))))
+
+(define (lst-index lst o)
+  (let loop ((lst lst) (i 0))
+    (and (pair? lst)
+         (if (eq? o (car lst)) i
+             (loop (cdr lst) (1+ i))))))
+
+;; (define-record-type <employee>
+;;   (make-employee name age salary)
+;;   employee?
+;;   (name employe-name)
+;;   (age employee-age set-employee-age!)
+;;   (salary employee-salary))
+
+;; (display <employee>)
+;; (newline)
+
+;; (display make-employee)
+;; (newline)
+;; (display "employee-age ")
+;; (display employee-age)
+;; (newline)
+
+;; (display "set-employee-age! ")
+;; (display set-employee-age!)
+;; (newline)
+
+;; (define janneke (make-employee "janneke" 49 42))
+;; (display janneke)
+;; (newline)
+
+;; (display (employee-age janneke))
+;; (newline)
+
+;; (display (set-employee-age! janneke 33))
+;; (newline)
+;; (display (employee-age janneke))
+;; (newline)

mes/module/srfi/srfi-9-vector.mes

@@ -0,0 +1,116 @@
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2017,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/>.
+
+;;; Commentary:
+
+;;; srfi-9-vector.mes - records, based on vector
+
+(define-macro (define-record-type type constructor+params predicate . fields)
+  (let ((record (make-record-type type (map car fields))))
+   `(begin
+      (define ,type ,record)
+      (define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
+      (define ,predicate ,(record-predicate record))
+      (define-record-accessors ,record ,@fields))))
+
+(define (make-record-type type fields)
+  (list->vector (list '*record-type* type fields (length fields))))
+
+(define (record-type? o)
+  (eq? (record-type o) '*record-type*))
+
+(define (record-type o)
+  (vector-ref o 0))
+
+(define (record-predicate type)
+  (lambda (o)
+    (and (vector? o)
+         (eq? (record-type o) type))))
+
+(define (record-constructor type params)
+  (let ((fields (record-fields type)))
+    (lambda (. o)
+      (if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
+          (let ((rest (make-list (- (length fields) (length params)))))
+            (list->vector (cons type (append o rest))))))))
+
+(define (record-fields o)
+  (vector-ref o 2))
+
+(define-macro (define-record-accessors type . fields)
+  `(begin
+     ,@(map (lambda (field)
+              `(define-record-accessor ,type ,field))
+            fields)))
+
+(define-macro (define-record-accessor type field)
+  `(begin
+     (define ,(cadr field) ,(record-getter type (car field)))
+     (if ,(pair? (cddr field))
+         (define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
+
+(define (record-getter type field)
+  (let ((i (record-field-index type field)))
+    (lambda (o . field?)
+      (if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
+          (if (pair? field?) field
+              (vector-ref o i))))))
+
+(define (record-setter type field)
+  (let ((i (record-field-index type field)))
+    (lambda (o v)
+      (if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
+          (vector-set! o i v)))))
+
+(define (record-field-index type field)
+  (1+ (or (lst-index (record-fields type) field)
+          (error "no such field" type field))))
+
+(define (lst-index lst o)
+  (let loop ((lst lst) (i 0))
+    (and (pair? lst)
+         (if (eq? o (car lst)) i
+             (loop (cdr lst) (1+ i))))))
+
+;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age  employee-age set-employee-age!) (salary employee-salary))
+
+;; (display <employee>)
+;; (newline)
+;; (display make-employee)
+;; (newline)
+;; (display "employee-age ")
+;; (display employee-age)
+;; (newline)
+
+;; (display "set-employee-age! ")
+;; (display set-employee-age!)
+;; (newline)
+
+;; (define janneke (make-employee "janneke" 49 42))
+;; (display janneke)
+;; (newline)
+
+;; (display (employee-age janneke))
+;; (newline)
+
+;; (display (set-employee-age! janneke 33))
+;; (newline)
+;; (display (employee-age janneke))
+;; (newline)

mes/module/srfi/srfi-9.mes

@@ -1,138 +0,0 @@
-;;; -*-scheme-*-
-
-;;; GNU Mes --- Maxwell Equations of Software
-;;; Copyright © 2017 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/>.
-
-;;; Commentary:
-
-;;; srfi-9.mes - records.
-
-(define (lst-index lst o)
-  (let loop ((lst lst) (i 0))
-    (and (pair? lst)
-         (if (equal? o (car lst)) i
-             (loop (cdr lst) (1+ i))))))
-
-(define (make-record-type type fields)
-  (list->vector (list '*record-type* type fields (length fields))))
-
-(define (record-type o)
-  (vector-ref o 0))
-
-(define (record-type? o)
-  (eq? (record-type o) '*record-type*))
-
-(define (record-constructor type params)
-  (let ((fields (record-fields type)))
-    (lambda (. o)
-      (if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
-          (let ((rest (make-list (- (length fields) (length params)))))
-            (list->vector (cons type (append o rest))))))))
-
-(define (record-fields o)
-  (vector-ref o 2))
-
-(define (record-field-index type field)
-  (1+ (or (lst-index (record-fields type) field)
-          (error "no such field" type field))))
-
-(define (record-getter type field)
-  (let ((i (record-field-index type field)))
-    (lambda (o . field?)
-      (if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
-          (if (pair? field?) field
-              (vector-ref o i))))))
-
-(define (record-setter type field)
-  (let ((i (record-field-index type field)))
-    (lambda (o v)
-      (if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
-          (vector-set! o i v)))))
-
-(define (record-predicate type)
-  (lambda (o)
-    (and (vector? o)
-         (eq? (record-type o) type))))
-
-(define-macro (define-record-accessors type . fields)
-  `(begin
-     ,@(map (lambda (field)
-              `(define-record-accessor ,type ,field))
-            fields)))
-
-(define-macro (define-record-accessor type field)
-  `(begin
-     (define ,(cadr field) ,(record-getter type (car field)))
-     (if ,(pair? (cddr field))
-         (define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
-
-(define-macro (define-record-type type constructor+params predicate . fields)
-  (let ((record (make-record-type type (map car fields))))
-   `(begin
-      (define ,type ,record)
-      (define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
-      (define ,predicate ,(record-predicate record))
-      (define-record-accessors ,record ,@fields))))
-
-;; (define-record-type cpi
-;;   (make-cpi-1)
-;;   cpi?
-;;   (debug cpi-debug set-cpi-debug!)	; debug #t #f
-;;   (defines cpi-defs set-cpi-defs!)	; #defines
-;;   (incdirs cpi-incs set-cpi-incs!)	; #includes
-;;   (inc-tynd cpi-itynd set-cpi-itynd!)	; a-l of incfile => typenames
-;;   (inc-defd cpi-idefd set-cpi-idefd!)	; a-l of incfile => defines
-;;   (ptl cpi-ptl set-cpi-ptl!)		; parent typename list
-;;   (ctl cpi-ctl set-cpi-ctl!)		; current typename list
-;;   (blev cpi-blev set-cpi-blev!)		; curr brace/block level
-;;   )
-
-;; (display cpi)
-;; (newline)
-;; (display make-cpi-1)
-;; (newline)
-;; (define cpi (make-cpi-1))
-;; (set-cpi-debug! cpi #t)
-;; (set-cpi-blev! cpi #t)
-
-
-;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age  employee-age set-employee-age!) (salary employee-salary))
-
-;; (display <employee>)
-;; (newline)
-;; (display make-employee)
-;; (newline)
-;; (display "employee-age ")
-;; (display employee-age)
-;; (newline)
-
-;; (display "set-employee-age! ")
-;; (display set-employee-age!)
-;; (newline)
-
-;; (define janneke (make-employee "janneke" 49 42))
-;; (display janneke)
-;; (newline)
-
-;; (display (employee-age janneke))
-;; (newline)
-
-;; (display (set-employee-age! janneke 33))
-;; (newline)
-;; (display (employee-age janneke))
-;; (newline)

mes/module/srfi/srfi-9.mes

@@ -0,0 +1 @@
+srfi-9-struct.mes

mes/module/srfi/srfi-9/gnu-struct.mes

@@ -0,0 +1,38 @@
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2017,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/>.
+
+;;; Commentary:
+
+;;; srfi-9.mes - GNU immutable records.
+
+(define-macro (define-immutable-record-type type constructor+params predicate . fields)
+  `(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
+
+(define-macro (set-field o getters value)
+  `(let ((getter ,(car getters)))
+     (let* ((type (struct-vtable ,o))
+            (name (record-type ,o))
+            (set (getter ,o #t)))
+       (define (field->value field)
+         (if (eq? set field) ,value
+             ((record-getter type field) ,o)))
+       (let* ((fields (record-fields type))
+              (values (map field->value fields)))
+         (apply (record-constructor type name fields) values)))))

mes/module/srfi/srfi-9/gnu-vector.mes

@@ -0,0 +1,37 @@
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2017,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/>.
+
+;;; Commentary:
+
+;;; srfi-9.mes - GNU immutable records.
+
+(define-macro (define-immutable-record-type type constructor+params predicate . fields)
+  `(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
+
+(define-macro (set-field o getters value)
+  `(let ((getter ,(car getters)))
+     (let ((type (record-type ,o))
+           (set (getter ,o #t)))
+       (define (field->value field)
+         (if (eq? set field) ,value
+             ((record-getter type field) ,o)))
+       (let* ((fields (record-fields type))
+              (values (map field->value fields)))
+         (apply (record-constructor type fields) values)))))

mes/module/srfi/srfi-9/gnu.mes

@@ -1,37 +0,0 @@
-;;; -*-scheme-*-
-
-;;; GNU Mes --- Maxwell Equations of Software
-;;; Copyright © 2017,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/>.
-
-;;; Commentary:
-
-;;; srfi-9.mes - GNU immutable records.
-
-(define-macro (define-immutable-record-type type constructor+params predicate . fields)
-  `(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
-
-(define-macro (set-field o getters value)
-  `(let ((getter ,(car getters)))
-     (let ((type (record-type ,o))
-           (set (getter ,o #t)))
-       (define (field->value field)
-         (if (eq? set field) ,value
-             ((record-getter type field) ,o)))
-       (let* ((fields (record-fields type))
-              (values (map field->value fields)))
-         (apply (record-constructor type fields) values)))))

mes/module/srfi/srfi-9/gnu.mes

@@ -0,0 +1 @@
+gnu-struct.mes

module/mes/mes-0.scm

@@ -38,6 +38,11 @@
             %arch
             %compiler
             ))
+(cond-expand
+ (guile-2)
+ (guile
+  (define %host-type (string-append (utsname:machine (uname)) "linux-gnu")))
+ (else))
 
 (define-macro (mes-use-module . rest) #t)
 (define builtin? procedure?) ; not strictly true, but ok for tests/*.test

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

module/mes/test.scm

@@ -26,11 +26,13 @@
 ;;; Code:
 
 (define-module (mes test)
+  #:use-module (ice-9 rdelim)
   #:export (
             pass-if
             pass-if-equal
             pass-if-not
             pass-if-eq
+            pass-if-timeout
             result
             seq? ; deprecated
             sequal? ; deprecated
@@ -38,6 +40,7 @@
 
 (cond-expand
  (mes
+  (define (inexact->exact x) x)
   (define mes? #t)
   (define guile? #f)
   (define guile-2? #f)
@@ -104,6 +107,14 @@
         (display "actual: ") (display a) (newline)
         #f)))
 
+(define (sless? a expect)
+  (or (< a expect)
+      (begin
+        (display ": fail") (newline)
+        (display "expected: ") (display expect) (newline)
+        (display "actual: ") (display a) (newline)
+        #f)))
+
 (define (sequal2? actual expect)
   (or (equal? actual expect)
       (begin
@@ -132,3 +143,16 @@
    'begin
    (list display "test: ") (list display name)
    (list 'result (list not f)))) ;; FIXME
+
+(define internal-time-units-per-milli-second
+  (/ internal-time-units-per-second 1000))
+(define (test-time thunk)
+  ((lambda (start)
+     (begin
+       (thunk)
+       (inexact->exact (/ (- (get-internal-run-time) start)
+                          internal-time-units-per-milli-second))))
+   (get-internal-run-time)))
+
+(define-macro (pass-if-timeout name limit . body)
+  (list 'pass-if name (list sless? (list test-time (cons* 'lambda '_ body)) limit)))

module/mescc/M1.scm

@@ -87,7 +87,7 @@
                                      (dec->hex (quotient o #x100000000))))
       (string-append "%" (number->string (dec->hex (modulo o #x100000000)))
                      " %" (if (< o 0) "-1"
-                              (number->string (dec->hex (quoteint o #x100000000)))))))
+                              (number->string (dec->hex (quotient o #x100000000)))))))
 
 (define* (display-join o #:optional (sep ""))
   (let loop ((o o))

module/mescc/compile.scm

@@ -209,6 +209,7 @@
       ((mod ,a ,b) (ast->type a info))
       ((mul ,a ,b) (ast->type a info))
       ((not ,a) (ast->type a info))
+      ((pos ,a) (ast->type a info))
       ((neg ,a) (ast->type a info))
       ((eq ,a ,b) (ast->type a info))
       ((ge ,a ,b) (ast->type a info))
@@ -1218,6 +1219,9 @@
                 (info (append-text info (wrap-as (as info 'r-negate)))))
            (append-text info (wrap-as (as info 'test-r))))) ;; hmm, use ast->info?
 
+        ((pos ,expr)
+         (expr->register expr info))
+
         ((neg ,expr)
          (let* ((info (expr->register expr info))
                 (info (allocate-register info))
@@ -1542,6 +1546,7 @@
 (define (cstring->int o)
   (let ((o (cond ((string-suffix? "ULL" o) (string-drop-right o 3))
                  ((string-suffix? "UL" o) (string-drop-right o 2))
+                 ((string-suffix? "U" o) (string-drop-right o 1))
                  ((string-suffix? "LL" o) (string-drop-right o 2))
                  ((string-suffix? "L" o) (string-drop-right o 1))
                  (else o))))
@@ -1559,6 +1564,8 @@
   (pmatch o
     ((fixed ,a) (cstring->int a))
     ((p-expr ,expr) (expr->number info expr))
+    ((pos ,a)
+     (expr->number info a))
     ((neg ,a)
      (- (expr->number info a)))
     ((add ,a ,b)
@@ -2536,6 +2543,7 @@
 (define (fctn-defn:get-name o)
   (pmatch o
     ((_ (ftn-declr (ident ,name) _) _) name)
+    ((_ (ftn-declr (scope (ident ,name)) _) _) name)
     ((_ (ptr-declr (pointer . _) (ftn-declr (ident ,name) _)) _) name)
     (_ (error "fctn-defn:get-name not supported:" o))))
 
@@ -2609,6 +2617,7 @@
 (define (fctn-defn:get-statement o)
   (pmatch o
     ((_ (ftn-declr (ident _) _) ,statement) statement)
+    ((_ (ftn-declr (scope (ident _)) _) ,statement) statement)
     ((_ (ptr-declr (pointer . _) (ftn-declr (ident _) . _)) ,statement) statement)
     (_ (error "fctn-defn:get-statement: not supported: " o))))
 

module/mescc/mescc.scm

@@ -281,7 +281,7 @@
   (let ((status (apply system* args)))
     (when (not (zero? status))
       (stderr "mescc: failed: ~a\n" (string-join args))
-      (exit status))
+      (exit (status:exit-val status)))
     status))
 
 (define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))

scaffold/boot/37-closure-lambda.scm

@@ -16,9 +16,6 @@
 ;;; 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 (pair? x)
-  (eq? (core:type x) <cell:pair>))
-
 (define (atom? x)
   (if (pair? x) #f
       (if (null? x) #f

scaffold/boot/38-simple-format.scm

@@ -16,8 +16,6 @@
 ;;; 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 (pair? x) (eq? (core:type x) <cell:pair>))
-
 (define (not x) (if x #f #t))
 
 (define-macro (or . x)

scaffold/boot/4c-quasiquote.scm

@@ -16,7 +16,6 @@
 ;;; 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 (pair? x) (eq? (core:type x) <cell:pair>))
 (define (vector? x)
   (eq? (core:type x) <cell:vector>))
 
@@ -85,7 +84,7 @@
 ;;          ((lambda (a d)
 ;;             (core:display "  a=") (core:display a) (core:display "\n")
 ;;             (core:display "  d=") (core:display d)
-            
+
 ;;             (if (pair? d)
 ;;                 (if (eq? (car d) 'quote)
 ;;                     (if (and (pair? a) (eq? (car a) 'quote))
@@ -133,7 +132,7 @@
             (core:display "\n")
             (core:display "CDR d=") (core:display d)
             (core:display "\n")
-            
+
                  (if (pair? d)
                      (if (eq? (car d) 'quote)
                          (if (and (pair? a) (eq? (car a) 'quote))

scaffold/boot/51-module.scm

@@ -81,7 +81,7 @@
     (list 'load (list string-append %moduledir file)))
 
   (define (string->symbol s)
-    (core:lookup-symbol (core:car s)))
+    (list->symbol (core:car s)))
 
   (define (symbol->list s)
     (core:car s))

scaffold/boot/52-define-module.scm

@@ -69,7 +69,7 @@
 ;;;;;;;;;;;;;;;;;;
 
   (define (string->symbol s)
-    (core:lookup-symbol (core:car s)))
+    (list->symbol (core:car s)))
 
   (define-macro (load file)
     (list 'primitive-load file))

scaffold/boot/53-closure-display.scm

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

scaffold/boot/60-let-syntax-expanded.scm

@@ -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)))
@@ -36,7 +36,6 @@
 (define <cell:pair> 7)
 (define <cell:string> 10)
 
-(define (pair? x) (eq? (core:type x) <cell:pair>))
 (define (not x) (if x #f #t))
 
 (define (display x . rest)
@@ -139,35 +138,21 @@
       (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 (string->symbol s)
     (if (not (pair? (core:car s))) '()
-        (core:lookup-symbol (core:car s))))
+        (list->symbol (core:car s))))
 
   (define <cell:string> 10)
   (define (string? x)
     (eq? (core:type x) <cell:string>))
-  
+
   (define <cell:vector> 14)
   (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)
@@ -183,9 +168,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)))
@@ -362,14 +345,14 @@
         (and (segment-template? pattern)
              (or (null? (cddr pattern))
                  (syntax-error0 "segment matching not implemented" pattern))))
-    
+
       (define (segment-template? pattern)
         (and (pair? pattern)
              (pair? (cdr pattern))
              (memq (cadr pattern) indicators-for-zero-or-more)))
-    
+
       (define indicators-for-zero-or-more (list (string->symbol "...") '---))
-    
+
       (lambda (exp r c)
 
         (define %input (r '%input))     ;Gensym these, if you like.
@@ -406,7 +389,7 @@
                                        0
                                        (meta-variables pattern 0 '())))))
               (syntax-error2 "ill-formed syntax rule" rule)))
-      
+
         ;; Generate code to test whether input expression matches pattern
 
         (define (process-match input pattern)
@@ -427,7 +410,7 @@
                  `((eq? ,input ',pattern)))
                 (else
                  `((equal? ,input ',pattern)))))
-      
+
         (define (process-segment-match input pattern)
           ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
           ;;(core:display-error "              pattern:") (core:write-error pattern) (core:display-error "\n")
@@ -439,7 +422,7 @@
                         (and (pair? l)
                              ,@conjuncts
                              (loop (cdr l)))))))))
-      
+
         ;; Generate code to take apart the input expression
         ;; This is pretty bad, but it seems to work (can't say why).
 
@@ -560,5 +543,3 @@
                         (if (not condition)
                             (begin exp ...))))))
    (xwhen #f 42)))
-
-

scaffold/boot/60-let-syntax.scm

@@ -52,32 +52,18 @@
       (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 (string->symbol s)
     (if (not (pair? (core:car s))) '()
-        (core:lookup-symbol (core:car s))))
+        (list->symbol (core:car s))))
 
   (define (string? x)
     (eq? (core:type x) <cell:string>))
-  
+
   (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)
@@ -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)))
@@ -272,14 +256,14 @@
         (and (segment-template? pattern)
              (or (null? (cddr pattern))
                  (syntax-error "segment matching not implemented" pattern))))
-    
+
       (define (segment-template? pattern)
         (and (pair? pattern)
              (pair? (cdr pattern))
              (memq (cadr pattern) indicators-for-zero-or-more)))
-    
+
       (define indicators-for-zero-or-more (list (string->symbol "...") '---))
-    
+
       (lambda (exp r c)
 
         (define %input (r '%input))     ;Gensym these, if you like.
@@ -316,7 +300,7 @@
                                        0
                                        (meta-variables pattern 0 '())))))
               (syntax-error "ill-formed syntax rule" rule)))
-      
+
         ;; Generate code to test whether input expression matches pattern
 
         (define (process-match input pattern)
@@ -337,7 +321,7 @@
                  `((eq? ,input ',pattern)))
                 (else
                  `((equal? ,input ',pattern)))))
-      
+
         (define (process-segment-match input pattern)
           ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
           ;;(core:display-error "              pattern:") (core:write-error pattern) (core:display-error "\n")
@@ -349,7 +333,7 @@
                         (and (pair? l)
                              ,@conjuncts
                              (loop (cdr l)))))))))
-      
+
         ;; Generate code to take apart the input expression
         ;; This is pretty bad, but it seems to work (can't say why).
 
@@ -470,4 +454,3 @@
                         (if (not condition)
                             (begin exp ...))))))
    (xwhen #f 42)))
-

scaffold/mini-mes.c

@@ -34,6 +34,7 @@
 
 int ARENA_SIZE = 200000; // 32b: 2MiB, 64b: 4 MiB
 int MAX_ARENA_SIZE = 300000000;
+long STACK_SIZE = 20000;
 int JAM_SIZE = 20000;
 int GC_SAFETY = 2000;
 
@@ -48,6 +49,9 @@ SCM g_symbols = 0;
 SCM g_macros = 0;
 SCM g_ports = 0;
 SCM g_stack = 0;
+SCM *g_stack_array = 0;
+#define FRAME_SIZE 5
+#define FRAME_PROCEDURE 4
 // a/env
 SCM r0 = 0;
 // param 1
@@ -56,8 +60,10 @@ SCM r1 = 0;
 SCM r2 = 0;
 // continuation
 SCM r3 = 0;
+// current-module
+SCM m0 = 0;
 
-enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
+enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
 
 struct scm {
   enum type_t type;
@@ -117,6 +123,7 @@ struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
 struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
+struct scm scm_symbol_boot_module = {TSYMBOL, "boot-module",0};
 struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
 struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
 struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
@@ -131,6 +138,15 @@ struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0}
 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
 struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
 
+struct scm scm_symbol_hashq_table = {TSYMBOL, "<hashq-table>",0};
+struct scm scm_symbol_record_type = {TSYMBOL, "<record-type>",0};
+struct scm scm_symbol_frame = {TSYMBOL, "<frame>",0};
+struct scm scm_symbol_module = {TSYMBOL, "<module>",0};
+struct scm scm_symbol_stack = {TSYMBOL, "<stack>",0};
+struct scm scm_symbol_buckets = {TSYMBOL, "buckets",0};
+struct scm scm_symbol_procedure = {TSYMBOL, "procedure",0};
+struct scm scm_symbol_size = {TSYMBOL, "size",0};
+
 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
 struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
 struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
@@ -189,12 +205,14 @@ struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
 struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
 struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
 struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
+struct scm scm_type_struct = {TSYMBOL, "<cell:struct>",0};
 struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
 struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
 struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
 struct scm scm_type_vector = {TSYMBOL, "<cell:vector>",0};
 struct scm scm_type_broken_heart = {TSYMBOL, "<cell:broken-heart>",0};
 
+struct scm scm_symbol_internal_time_units_per_second = {TSYMBOL, "internal-time-units-per-second",0};
 struct scm scm_symbol_compiler = {TSYMBOL, "%compiler",0};
 struct scm scm_symbol_arch = {TSYMBOL, "%arch",0};
 
@@ -234,6 +252,7 @@ SCM gc_init_news ();
 #define LENGTH(x) g_cells[x].car
 #define REF(x) g_cells[x].car
 #define STRING(x) g_cells[x].car
+#define STRUCT(x) g_cells[x].cdr
 #define VARIABLE(x) g_cells[x].car
 
 #define CLOSURE(x) g_cells[x].cdr
@@ -330,15 +349,15 @@ list_of_char_equal_p (SCM a, SCM b) ///((internal))
 }
 
 SCM
-lookup_symbol_ (SCM s)
+list_to_symbol (SCM lst)
 {
   SCM x = g_symbols;
   while (x) {
-    if (list_of_char_equal_p (STRING (CAR (x)), s) == cell_t) break;
+    if (list_of_char_equal_p (STRING (CAR (x)), lst) == cell_t) break;
     x = CDR (x);
   }
   if (x) x = CAR (x);
-  if (!x) x = make_symbol_ (s);
+  if (!x) x = make_symbol_ (lst);
   return x;
 }
 
@@ -451,6 +470,14 @@ length (SCM x)
 
 SCM apply (SCM, SCM, SCM);
 
+SCM
+assq_ref_env (SCM x, SCM a)
+{
+  x = assq (x, a);
+  if (x == cell_f) return cell_undefined;
+  return CDR (x);
+}
+
 SCM
 error (SCM key, SCM x)
 {
@@ -627,18 +654,27 @@ call (SCM fn, SCM x)
 SCM
 assq (SCM x, SCM a)
 {
-  //FIXME: move into fast-non eq_p-ing assq core:assq?
-  //while (a != cell_nil && x != CAAR (a)) a = CDR (a);
-  while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
+  while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f)
+    a = CDR (a);
   return a != cell_nil ? CAR (a) : cell_f;
 }
 
 SCM
-assq_ref_env (SCM x, SCM a)
+assoc_string (SCM x, SCM a) ///(internal))
 {
-  x = assq (x, a);
-  if (x == cell_f) return cell_undefined;
-  return CDR (x);
+  while (a != cell_nil && list_of_char_equal_p (STRING (x), STRING (CAAR (a))) == cell_f)
+    a = CDR (a);
+  return a != cell_nil ? CAR (a) : cell_f;
+}
+
+SCM
+assoc (SCM x, SCM a)
+{
+  if (TYPE (x) == TSTRING)
+    return assoc_string (x, a);
+  while (a != cell_nil && equal2_p (x, CAAR (a)) == cell_f)
+    a = CDR (a);
+  return a != cell_nil ? CAR (a) : cell_f;
 }
 
 SCM
@@ -681,11 +717,8 @@ make_closure_ (SCM args, SCM body, SCM a) ///((internal))
 }
 
 SCM
-lookup_macro_ (SCM x, SCM a) ///((internal))
+macro_get_handle (SCM name)
 {
-  if (TYPE (x) != TSYMBOL) return cell_f;
-  SCM m = assq_ref_env (x, a);
-  if (TYPE (m) == TMACRO) return MACRO (m);
   return cell_f;
 }
 
@@ -781,6 +814,19 @@ make_tmps (struct scm* cells)
 #endif
 #include "lib.c"
 
+SCM frame_printer (SCM frame)
+{
+}
+SCM make_stack (SCM stack)
+{
+}
+SCM stack_length (SCM stack)
+{
+}
+SCM stack_ref (SCM stack, SCM index)
+{
+}
+
 // Jam Collector
 SCM g_symbol_max;
 

scaffold/tests/9a-snprintf.c

@@ -0,0 +1,37 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+#include <libmes.h>
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+
+int
+main ()
+{
+  int n = snprintf (0, 0, "%s", "0123456");
+  eputs ("***n="); eputs (itoa (n)); eputs ("\n");
+  exit(n != 7);
+
+  /* if (n) */
+  /*   return 1; */
+  return 0;
+}

src/gc.c

@@ -23,6 +23,7 @@
 SCM
 gc_up_arena () ///((internal))
 {
+  long old_arena_bytes = (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm);
   if (ARENA_SIZE >> 1 < MAX_ARENA_SIZE >> 2)
     {
       ARENA_SIZE <<= 1;
@@ -31,7 +32,8 @@ gc_up_arena () ///((internal))
     }
   else
     ARENA_SIZE = MAX_ARENA_SIZE -JAM_SIZE;
-  void *p = realloc (g_cells-1, (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm));
+  long arena_bytes = (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm);
+  void *p = realloc (g_cells-1, arena_bytes+STACK_SIZE*sizeof (SCM));
   if (!p)
     {
       eputs ("realloc failed, g_free=");
@@ -43,12 +45,13 @@ gc_up_arena () ///((internal))
       exit (1);
     }
   g_cells = (struct scm*)p;
+  memcpy (p + arena_bytes, p + old_arena_bytes, STACK_SIZE*sizeof (SCM));
   g_cells++;
 
   return 0;
 }
 
-SCM
+void
 gc_flip () ///((internal))
 {
   if (g_debug > 2)
@@ -60,7 +63,6 @@ gc_flip () ///((internal))
   if (g_free > JAM_SIZE)
     JAM_SIZE = g_free + g_free / 2;
   memcpy (g_cells-1, g_news-1, (g_free+2)*sizeof (struct scm));
-  return g_stack;
 }
 
 SCM
@@ -70,7 +72,8 @@ gc_copy (SCM old) ///((internal))
     return g_cells[old].car;
   SCM new = g_free++;
   g_news[new] = g_cells[old];
-  if (NTYPE (new) == TVECTOR)
+  if (NTYPE (new) == TSTRUCT
+      || NTYPE (new) == TVECTOR)
     {
       NVECTOR (new) = g_free;
       for (long i=0; i<LENGTH (old); i++)
@@ -95,7 +98,7 @@ gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
   return cell_unspecified;
 }
 
-SCM
+void
 gc_loop (SCM scan) ///((internal))
 {
   SCM car;
@@ -131,7 +134,7 @@ gc_loop (SCM scan) ///((internal))
         }
       scan++;
     }
-  return gc_flip ();
+  gc_flip ();
 }
 
 SCM
@@ -199,14 +202,9 @@ gc_ () ///((internal))
   g_symbols = gc_copy (g_symbols);
   g_macros = gc_copy (g_macros);
   g_ports = gc_copy (g_ports);
-  SCM new = gc_copy (g_stack);
-  if (g_debug > 3)
-    {
-      eputs ("new=");
-      eputs (itoa (new));
-      eputs ("\n");
-    }
-  g_stack = new;
+  m0 = gc_copy (m0);
+  for (long i=g_stack; i<STACK_SIZE; i++)
+    g_stack_array[i]= gc_copy (g_stack_array[i]);
   gc_loop (1);
 }
 

src/hash.c

@@ -0,0 +1,237 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+SCM make_vector__ (long k);
+SCM vector_ref_ (SCM x, long i);
+SCM vector_set_x_ (SCM x, long i, SCM e);
+
+int
+hash_list_of_char (SCM lst, long size)
+{
+  int hash = VALUE (CAR (lst)) * 37;
+  if (TYPE (CDR (lst)) == TPAIR && TYPE (CADR (lst)) == TCHAR)
+    hash = hash + VALUE (CADR (lst)) * 43;
+  assert (size);
+  hash = hash % size;
+  return hash;
+}
+
+int
+hashq_ (SCM x, long size)
+{
+  if (TYPE (x) == TSPECIAL
+      || TYPE (x) == TSYMBOL)
+    return hash_list_of_char (STRING (x), size);  // FIXME: hash x directly
+  error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list ("hashq_: not a symbol")), x));
+}
+
+int
+hash_ (SCM x, long size)
+{
+  if (TYPE (x) == TSTRING)
+    return hash_list_of_char (STRING (x), size);
+  assert (0);
+  return hashq_ (x, size);
+}
+
+SCM
+hashq (SCM x, SCM size)
+{
+  assert (0);
+  return MAKE_NUMBER (hashq_ (x, VALUE (size)));
+}
+
+SCM
+hash (SCM x, SCM size)
+{
+  assert (0);
+  return MAKE_NUMBER (hash_ (x, VALUE (size)));
+}
+
+SCM
+hashq_get_handle (SCM table, SCM key, SCM dflt)
+{
+  long size = VALUE (struct_ref_ (table, 3));
+  unsigned hash = hashq_ (key, size);
+  SCM buckets = struct_ref_ (table, 4);
+  SCM bucket = vector_ref_ (buckets, hash);
+  SCM x = cell_f;
+  if (TYPE (dflt) == TPAIR)
+    x = CAR (dflt);
+  if (TYPE (bucket) == TPAIR)
+    x = assq (key, bucket);
+  return x;
+}
+
+SCM
+hashq_ref (SCM table, SCM key, SCM dflt)
+{
+#if defined (INLINE)
+  SCM x = hashq_get_handle (table, key, dflt);
+#else
+  long size = VALUE (struct_ref_ (table, 3));
+  unsigned hash = hashq_ (key, size);
+  SCM buckets = struct_ref_ (table, 4);
+  SCM bucket = vector_ref_ (buckets, hash);
+  SCM x = cell_f;
+  if (TYPE (dflt) == TPAIR)
+    x = CAR (dflt);
+  if (TYPE (bucket) == TPAIR)
+    x = assq (key, bucket);
+#endif
+  if (x != cell_f)
+    x = CDR (x);
+  return x;
+}
+
+SCM
+hash_ref (SCM table, SCM key, SCM dflt)
+{
+  long size = VALUE (struct_ref_ (table, 3));
+  unsigned hash = hash_ (key, size);
+  SCM buckets = struct_ref_ (table, 4);
+  SCM bucket = vector_ref_ (buckets, hash);
+  SCM x = cell_f;
+  if (TYPE (dflt) == TPAIR)
+    x = CAR (dflt);
+  if (TYPE (bucket) == TPAIR)
+    {
+      x = assoc (key, bucket);
+      if (x != cell_f)
+        x = CDR (x);
+    }
+  return x;
+}
+
+#if defined (INLINE)
+#error INLINE
+SCM
+hash_set_x_ (SCM table, unsigned hash, SCM key, SCM value)
+{
+  SCM buckets = struct_ref_ (table, 4);
+  SCM bucket = vector_ref_ (buckets, hash);
+  if (TYPE (bucket) != TPAIR)
+    bucket = cell_nil;
+  bucket = acons (key, value, bucket);
+  vector_set_x_ (buckets, hash, bucket);
+  return value;
+}
+#endif
+
+SCM
+hashq_set_x (SCM table, SCM key, SCM value)
+{
+  long size = VALUE (struct_ref_ (table, 3));
+  unsigned hash = hashq_ (key, size);
+#if defined (INLINE)
+  return hash_set_x_ (table, hash, key, value);
+#else
+  SCM buckets = struct_ref_ (table, 4);
+  SCM bucket = vector_ref_ (buckets, hash);
+  if (TYPE (bucket) != TPAIR)
+    bucket = cell_nil;
+  bucket = acons (key, value, bucket);
+  vector_set_x_ (buckets, hash, bucket);
+  return value;
+#endif
+}
+
+SCM
+hash_set_x (SCM table, SCM key, SCM value)
+{
+  long size = VALUE (struct_ref_ (table, 3));
+  unsigned hash = hash_ (key, size);
+#if defined (INLINE)
+  return hash_set_x_ (table, hash, key, value);
+#else
+  SCM buckets = struct_ref_ (table, 4);
+  SCM bucket = vector_ref_ (buckets, hash);
+  if (TYPE (bucket) != TPAIR)
+    bucket = cell_nil;
+  bucket = acons (key, value, bucket);
+  vector_set_x_ (buckets, hash, bucket);
+  return value;
+#endif
+}
+
+SCM
+hash_table_printer (SCM table)
+{
+  fdputs ("#<", g_stdout); display_ (struct_ref_ (table, 2)); fdputc (' ', g_stdout);
+  fdputs ("size: ", g_stdout); display_ (struct_ref_ (table, 3)); fdputc (' ', g_stdout);
+  SCM buckets = struct_ref_ (table, 4);
+  fdputs ("buckets: ", g_stdout);
+  for (int i=0; i<LENGTH (buckets); i++)
+    {
+      SCM e = vector_ref_ (buckets, i);
+      if (e != cell_unspecified)
+        {
+          fdputc ('[', g_stdout);
+          while (TYPE (e) == TPAIR)
+            {
+              write_ (CAAR (e));
+              e = CDR (e);
+              if (TYPE (e) == TPAIR)
+                fdputc (' ', g_stdout);
+            }
+          fdputs ("]\n  ", g_stdout);
+        }
+    }
+  fdputc ('>', g_stdout);
+}
+
+SCM
+make_hashq_type () ///((internal))
+{
+  SCM record_type = cell_symbol_record_type; // FIXME
+  SCM fields = cell_nil;
+  fields = cons (cell_symbol_buckets, fields);
+  fields = cons (cell_symbol_size, fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_hashq_table, fields);
+  return make_struct (record_type, fields, cell_unspecified);
+}
+
+SCM
+make_hash_table_ (long size)
+{
+  if (!size)
+    size = 100;
+  SCM hashq_type = make_hashq_type ();
+
+  SCM buckets = make_vector__ (size);
+  SCM values = cell_nil;
+  values = cons (buckets, values);
+  values = cons (MAKE_NUMBER (size), values);
+  values = cons (cell_symbol_hashq_table, values);
+  return make_struct (hashq_type, values, cell_hash_table_printer);
+}
+
+SCM
+make_hash_table (SCM x)
+{
+  long size = 0;
+  if (TYPE (x) == TPAIR)
+    {
+      assert (TYPE (x) == TNUMBER);
+      size = VALUE (x);
+    }
+  return make_hash_table_ (size);
+}

src/lib.c

@@ -55,7 +55,12 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
   else if (t == TCLOSURE)
     {
       fdputs ("#<closure ", fd);
-      display_helper (CDR (x), cont, "", fd, 0);
+      SCM circ = CADR (x);
+      SCM name = CADR (circ);
+      SCM args = CAR (CDDR (x));
+      display_helper (CAR (name), 0, "", fd, 0);
+      fdputc (' ', fd);
+      display_helper (args, 0, "", fd, 0);
       fdputs (">", fd);
     }
   else if (t == TFUNCTION)
@@ -166,11 +171,34 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
       if (TYPE (x) == TPORT)
         fdputs (">", fd);
     }
+  else if (t == TREF)
+    fdisplay_ (REF (x), fd, write_p);
+  else if (t == TSTRUCT)
+    {
+      SCM printer = STRUCT (x) + 1;
+      if (TYPE (printer) == TREF)
+        printer = REF (printer);
+      if (printer != cell_unspecified)
+        apply (printer, cons (x, cell_nil), r0);
+      else
+        {
+          fdputs ("#<", fd);
+          fdisplay_ (STRUCT (x), fd, write_p);
+          SCM t = CAR (x);
+          long size = LENGTH (x);
+          for (long i=2; i<size; i++)
+            {
+              fdputc (' ', fd);
+              fdisplay_ (STRUCT (x) + i, fd, write_p);
+            }
+          fdputc ('>', fd);
+        }
+    }
   else if (t == TVECTOR)
     {
       fdputs ("#(", fd);
       SCM t = CAR (x);
-      for (long i = 0; i < LENGTH (x); i++)
+      for (long i = 0; i<LENGTH (x); i++)
         {
           if (i)
             fdputc (' ', fd);
@@ -245,6 +273,84 @@ exit_ (SCM x) ///((name . "exit"))
   exit (VALUE (x));
 }
 
+#if !MES_MINI
+SCM
+frame_printer (SCM frame)
+{
+  fdputs ("#<", g_stdout); display_ (struct_ref_ (frame, 2));
+  fdputc (' ', g_stdout);
+  fdputs ("procedure: ", g_stdout); display_ (struct_ref_ (frame, 3));
+  fdputc ('>', g_stdout);
+}
+
+SCM
+make_frame_type () ///((internal))
+{
+  SCM record_type = cell_symbol_record_type; // FIXME
+  SCM fields = cell_nil;
+  fields = cons (cell_symbol_procedure, fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_frame, fields);
+  return make_struct (record_type, fields, cell_unspecified);
+}
+
+SCM
+make_frame (SCM stack, long index)
+{
+  SCM frame_type = make_frame_type ();
+  long array_index = (STACK_SIZE-(index*FRAME_SIZE));
+  SCM procedure = g_stack_array[array_index+FRAME_PROCEDURE];
+  if (!procedure)
+    procedure = cell_f;
+  SCM values = cell_nil;
+  values = cons (procedure, values);
+  values = cons (cell_symbol_frame, values);
+  return make_struct (frame_type, values, cell_frame_printer);
+}
+
+SCM
+make_stack_type () ///((internal))
+{
+  SCM record_type = cell_symbol_record_type; // FIXME
+  SCM fields = cell_nil;
+  fields = cons (cstring_to_symbol ("frames"), fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_stack, fields);
+  return make_struct (record_type, fields, cell_unspecified);
+}
+
+SCM
+make_stack (SCM stack) ///((arity . n))
+{
+  SCM stack_type = make_stack_type ();
+  long size = (STACK_SIZE-g_stack) / FRAME_SIZE;
+  SCM frames = make_vector__ (size);
+  for (long i=0; i<size; i++)
+    {
+      SCM frame = make_frame (stack, i);
+      vector_set_x_ (frames, i, frame);
+    }
+  SCM values = cell_nil;
+  values = cons (frames, values);
+  values = cons (cell_symbol_stack, values);
+  return make_struct (stack_type, values, cell_unspecified);
+}
+
+SCM
+stack_length (SCM stack)
+{
+  SCM frames = struct_ref_ (stack, 3);
+  return vector_length (frames);
+}
+
+SCM
+stack_ref (SCM stack, SCM index)
+{
+  SCM frames = struct_ref_ (stack, 3);
+  return vector_ref (frames, index);
+}
+#endif // !MES_MINI
+
 SCM
 xassq (SCM x, SCM a) ///for speed in core only
 {
@@ -325,3 +431,9 @@ last_pair (SCM x)
     x = CDR (x);
   return x;
 }
+
+SCM
+pair_p (SCM x)
+{
+  return TYPE (x) == TPAIR ? cell_t : cell_f;
+}

src/module.c

@@ -0,0 +1,124 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+SCM struct_ref_ (SCM x, long i);
+SCM struct_set_x_ (SCM x, long i, SCM e);
+
+SCM
+make_module_type () ///(internal))
+{
+  SCM record_type = cell_symbol_record_type; // FIXME
+  SCM fields = cell_nil;
+  fields = cons (cstring_to_symbol ("globals"), fields);
+  fields = cons (cstring_to_symbol ("locals"), fields);
+  fields = cons (cstring_to_symbol ("name"), fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_module, fields);
+  return make_struct (record_type, fields, cell_unspecified);
+}
+
+SCM
+make_initial_module (SCM a) ///((internal))
+{
+  SCM module_type = make_module_type ();
+  a = acons (cell_symbol_module, module_type, a);
+
+  SCM hashq_type = make_hashq_type ();
+  a = acons (cell_symbol_hashq_table, hashq_type, a);
+
+  SCM name = cons (cstring_to_symbol ("boot"), cell_nil);
+  SCM globals = make_hash_table_ (0);
+  SCM locals = cell_nil;
+
+  SCM values = cell_nil;
+  values = cons (globals, values);
+  values = cons (locals, values);
+  values = cons (name, values);
+  values = cons (cell_symbol_module, values);
+  SCM module = make_struct (module_type, values, cell_module_printer);
+  r0 = cell_nil;
+  r0 = cons (CADR (a), r0);
+  r0 = cons (CAR (a), r0);
+  m0 = module;
+  while (TYPE (a) == TPAIR)
+    {
+      if (g_debug > 3)
+        {
+          eputs ("entry="); write_error_ (CAR (a)); eputs ("\n");
+        }
+      module_define_x (module, CAAR (a), CDAR (a));
+      a = CDR (a);
+    }
+
+  return module;
+}
+
+SCM
+module_printer (SCM module)
+{
+  //module = m0;
+  fdputs ("#<", g_stdout); display_ (struct_ref_ (module, 2)); fdputc (' ', g_stdout);
+  fdputs ("name: ", g_stdout); display_ (struct_ref_ (module, 3)); fdputc (' ', g_stdout);
+  fdputs ("locals: ", g_stdout); display_ (struct_ref_ (module, 4)); fdputc (' ', g_stdout);
+  SCM table = struct_ref_ (module, 5);
+  fdputs ("globals:\n  ", g_stdout);
+  display_ (table);
+  fdputc ('>', g_stdout);
+}
+
+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)
+    {
+      module = m0;
+      SCM globals = struct_ref_ (module, 5);
+      x = hashq_get_handle (globals, name, cell_f);
+    }
+  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;
+  return CDR (x);
+}
+
+SCM
+module_define_x (SCM module, SCM name, SCM value)
+{
+  if (g_debug > 4)
+    {
+      eputs ("module_define_x: "); display_error_ (name); eputs ("\n");
+    }
+  module = m0;
+  SCM globals = struct_ref_ (module, 5);
+  return hashq_set_x (globals, name, value);
+}

src/posix.c

@@ -18,10 +18,12 @@
  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
-#include <sys/stat.h>
-#include <sys/wait.h>
 #include <fcntl.h>
 #include <stdlib.h>
+#include <sys/stat.h>
+#include <sys/time.h>
+#include <sys/wait.h>
+#include <time.h>
 #include <unistd.h>
 
 int readchar ();
@@ -110,8 +112,11 @@ write_char (SCM i) ///((arity . n))
 }
 
 SCM
-read_string ()
+read_string (SCM port) ///((arity . n))
 {
+  int fd = g_stdin;
+  if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
+    g_stdin = VALUE (CAR (port));
   SCM lst = cell_nil;
   SCM c = read_char ();
   while (VALUE (c) != -1)
@@ -119,6 +124,7 @@ read_string ()
       lst = append2 (lst, cons (c, cell_nil));
       c = read_char ();
     }
+  g_stdin = fd;
   return MAKE_STRING (lst);
 }
 
@@ -303,3 +309,50 @@ waitpid_ (SCM pid, SCM options)
   int child = waitpid (VALUE (pid), &status, VALUE (options));
   return cons (MAKE_NUMBER (child), MAKE_NUMBER (status));
 }
+
+#if __x86_64__
+/* Nanoseconds on 64-bit systems with POSIX timers.  */
+#define TIME_UNITS_PER_SECOND 1000000000
+#else
+/* Milliseconds for everyone else.  */
+#define TIME_UNITS_PER_SECOND 1000
+#endif
+
+struct timespec g_start_time;
+SCM
+init_time (SCM a) ///((internal))
+{
+  clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &g_start_time);
+  a = acons (cell_symbol_internal_time_units_per_second, MAKE_NUMBER (TIME_UNITS_PER_SECOND), a);
+}
+
+SCM
+current_time ()
+{
+  return MAKE_NUMBER (time (0));
+}
+
+SCM
+gettimeofday_ () ///((name . "gettimeofday"))
+{
+  struct timeval time;
+  gettimeofday (&time, 0);
+  return cons (MAKE_NUMBER (time.tv_sec), MAKE_NUMBER (time.tv_usec));
+}
+
+long
+seconds_and_nanoseconds_to_long (long s, long ns)
+{
+  return s * TIME_UNITS_PER_SECOND
+    + ns / (1000000000 / TIME_UNITS_PER_SECOND);
+}
+
+SCM
+get_internal_run_time ()
+{
+  struct timespec ts;
+  clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts);
+  long time = seconds_and_nanoseconds_to_long (ts.tv_sec - g_start_time.tv_sec,
+                                               ts.tv_nsec - g_start_time.tv_nsec);
+  return MAKE_NUMBER (time);
+}

src/reader.c

@@ -34,8 +34,9 @@ read_input_file_env_ (SCM e, SCM a)
 SCM
 read_input_file_env (SCM a)
 {
-  r0 = a;
-  return read_input_file_env_ (read_env (r0), r0);
+  //r0 = a;
+  //return read_input_file_env_ (read_env (r0), r0);
+  return read_input_file_env_ (read_env (cell_nil), cell_nil);
 }
 
 int
@@ -103,7 +104,7 @@ reader_read_identifier_or_number (int c)
     }
   unreadchar (c);
   buf[i] = 0;
-  return lookup_symbol_ (cstring_to_list (buf));
+  return cstring_to_symbol (buf);
 }
 
 SCM

src/struct.c

@@ -0,0 +1,83 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+SCM
+make_struct (SCM type, SCM fields, SCM printer)
+{
+  long size = 2 + length__ (fields);
+  SCM v = alloc (size);
+  SCM x = make_cell__ (TSTRUCT, size, v);
+  g_cells[v] = g_cells[vector_entry (type)];
+  g_cells[v+1] = g_cells[vector_entry (printer)];
+  for (long i=2; i<size; i++)
+    {
+      SCM e = cell_unspecified;
+      if (fields != cell_nil)
+        {
+          e = CAR (fields);
+          fields = CDR (fields);
+        }
+      g_cells[v+i] = g_cells[vector_entry (e)];
+    }
+  return x;
+}
+
+SCM
+struct_length (SCM x)
+{
+  assert (TYPE (x) == TSTRUCT);
+  return MAKE_NUMBER (LENGTH (x));
+}
+
+SCM
+struct_ref_ (SCM x, long i)
+{
+  assert (TYPE (x) == TSTRUCT);
+  assert (i < LENGTH (x));
+  SCM e = STRUCT (x) + i;
+  if (TYPE (e) == TREF)
+    e = REF (e);
+  if (TYPE (e) == TCHAR)
+    e = MAKE_CHAR (VALUE (e));
+  if (TYPE (e) == TNUMBER)
+    e = MAKE_NUMBER (VALUE (e));
+  return e;
+}
+
+SCM
+struct_set_x_ (SCM x, long i, SCM e)
+{
+  assert (TYPE (x) == TSTRUCT);
+  assert (VALUE (i) < LENGTH (x));
+  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));
-  SCM e = VECTOR (x) + VALUE (i);
+  assert (i < LENGTH (x));
+  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));
-  g_cells[VECTOR (x)+VALUE (i)] = g_cells[vector_entry (e)];
+  assert (i < LENGTH (x));
+  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/catch.test

@@ -54,18 +54,17 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
     (lambda (key . args)
       789)))
 
-(if mes?
-    (pass-if-equal "catch feel"
-        1
-      (let ((save-exit exit))
-        (set! exit (lambda (x)
-                     (set! exit save-exit)
-                     1))
-        (catch 'boo
-          (lambda ()
-            (throw-22)
-            11)
-          (lambda (key . args)
-            22)))))
+(pass-if-equal "catch feel"
+               1
+               (catch 'twenty-two
+                 (lambda _
+                   (catch 'boo
+                     (lambda ()
+                       (throw-22)
+                       11)
+                     (lambda (key . args)
+                       (exit 1))))
+                 (lambda (key . args)
+                   1)))
 
 (result 'report)

tests/fluids.test

@@ -51,14 +51,14 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 ;;     0 (with-fluids* (list a b) '(0 1)
 ;;                     (lambda () (fluid-ref a))))
 
-(pass-if-equal "with-fluids"
+(pass-if-eq "with-fluids"
     0 (with-fluids ((a 1)
                     (a 2)
                     (a 3))
         (fluid-set! a 0)
         (fluid-ref a)))
 
-(pass-if-equal "with-fluids" ; FIXME: fails with Mes
+(pass-if-eq "with-fluids"
     #f (begin
          (with-fluids ((a 1)
                        (b 2))
@@ -66,4 +66,4 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
            (display "X:") (display (fluid-ref a)) (newline))
          (fluid-ref a)))
 
-(result 'report (if mes? 1 0))
+(result 'report)

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/perform.test

@@ -0,0 +1,58 @@
+#! /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 perform)' -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
+  (define (round x) x)
+  (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)
+
+(pass-if-timeout "loop 1M"
+                 100
+                 ((lambda (loop)
+                    (set! loop
+                          (lambda (i)
+                            (if (> i 0)
+                                (loop (- i 1)))))
+                    (loop 100000))
+                  *unspecified*))
+
+(result 'report (if mes? 1 0)) ; at least until we have bogomips,
+                               ; allow mes to fail

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)