local expand: only 1 failure: 60-let-syntax.

* scaffold/boot/2h-recurse-twice.scm: New file.
* scaffold/boot/2h-recurse-twice-cond.scm: New file.
* scaffold/boot/4c-quasiquote.scm: Update.
* build-aux/check-boot.sh: Add them.

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
+sh ${srcdest}build-aux/snarf.sh
-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
 
 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
+sh ${srcdest}build-aux/snarf.sh --mes
-# 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
 
 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
+sh ${srcdest}build-aux/snarf.sh --mes
-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
 
 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
+sh ${srcdest}build-aux/snarf.sh --mes
-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
 
 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
+sh ${srcdest}build-aux/snarf.sh --mes
-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
 
 if [ -n "$SEED" ]; then
     bash ${srcdest}build-aux/cc-mes.sh src/mes

build-aux/check-boot.sh

@@ -75,6 +75,8 @@ tests="
 2f-define-second.scm
 2f-define-second-lambda.scm
 2g-vector.scm
+2h-recurse-twice.scm
+2h-recurse-twice-cond.scm
 
 30-capture.scm
 31-capture-define.scm
@@ -101,10 +103,10 @@ tests="
 49-macro-override.scm
 4a-define-macro-define-macro.scm
 4b-define-macro-define.scm
+4f-string-split.scm
 4c-quasiquote.scm
 4d-let-map.scm
 4e-let-global.scm
-4f-string-split.scm
 
 50-primitive-load.scm
 51-module.scm

build-aux/check-mes.sh

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

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 (list_to_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.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

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

lib/libmes.c

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

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

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

mes/module/mes/boot-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)))

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

mes/module/mes/display.mes

@@ -115,10 +115,13 @@
        ((port? x)
         (display "#<port " port)
         (display (core:cdr x) port)
+        (display " ")
         (display (core:car x) port)
         (display ">" port))
        ((variable? x)
         (display "#<variable " port)
+        (when (not (zero? (core:cdr x)))
+          (display "*local* " port))
         (write (list->string (car (core:car x))) port)
         (display ">" port))
        ((number? x)
@@ -142,6 +145,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)

mes/module/mes/fluids.mes

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

@@ -27,6 +27,5 @@
 
 (define datum->syntax datum->syntax-object)
 (define syntax->datum syntax-object->datum)
-(define-macro (portable-macro-expand) #t)
+(define-macro (portable-macro-expand) '(begin #t))
 (set! macro-expand sc-expand)
-

mes/module/mes/repl.mes

@@ -136,7 +136,7 @@ along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
     (define (quit . x)
       (exit 0))
     (define (use a)
-      (lambda ()
+      (lambda (. x)
         (let ((module (read)))
           (mes-load-module-env module a))))
     (define (meta command a)

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>))
@@ -86,6 +87,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 +123,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/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/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))

scaffold/boot/2h-recurse-twice-cond.scm

@@ -0,0 +1,50 @@
+;;; 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 display core:display)
+(define (newline) (core:display "\n"))
+(define (pair? x) (eq? (core:type x) <cell:pair>))
+(define (not x) (if x #f #t))
+
+(define-macro (cond . clauses)
+  (list 'if (pair? clauses)
+        (list (cons
+               'lambda
+               (cons
+                '(test)
+                (list (list 'if 'test
+                            (if (pair? (cdr (car clauses)))
+                                (if (eq? (car (cdr (car clauses))) '=>)
+                                    (append2 (cdr (cdr (car clauses))) '(test))
+                                    (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
+                                (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
+                            (if (pair? (cdr clauses))
+                                (cons 'cond (cdr clauses)))))))
+              (car (car clauses)))))
+
+(define (f x)
+  (display "x=") (display x) (newline)
+  (cond ((not (pair? x)) 'dun)
+        (#t
+         ((lambda (h t)
+            (list h t))
+          (f (car x))
+          (f (cdr x))))))
+
+(display (f '(42)))
+(newline)

scaffold/boot/2h-recurse-twice.scm

@@ -0,0 +1,33 @@
+;;; 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 display core:display)
+(define (newline) (core:display "\n"))
+(define (pair? x) (eq? (core:type x) <cell:pair>))
+(define (not x) (if x #f #t))
+
+(define (f x)
+  (display "x=") (display x) (newline)
+  (if (not (pair? x)) 'dun
+      ((lambda (h t)
+         (list h t))
+       (f (car x))
+       (f (cdr x)))))
+
+(display (f '(42)))
+(newline)

scaffold/boot/4c-quasiquote.scm

@@ -55,51 +55,6 @@
       (if (eq? x (car lst)) lst
           (memq x (cdr lst)))))
 
-;; (define (quasiquote-expand x)
-;;   (core:display "quasiquote-expand x=") (core:display x) (core:display "\n")
-;;   (cond ((null? x)
-;;          (core:display "NULL\n")
-;;          '())
-;;         ((vector? x)
-;;          (core:display "vector\n")
-;;          (list 'list->vector (quasiquote-expand (vector->list x))))
-;;         ((not (pair? x))
-;;          (core:display "NOT a pair\n")
-;;          (cons 'quote (cons x '())))
-;;         ((eq? (car x) 'quasiquote) (quasiquote-expand (quasiquote-expand
-;;                                                        (if (null? (cddr x)) (cadr x)
-;;                                                            (cons 'list (cdr x))))))
-;;         ((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
-;;                                     (cons 'list (cdr x))))
-;;         ((and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
-;;          ((lambda (d)
-;;             (if (null? (cddar x)) (list 'append (cadar x) d)
-;;                 (list 'quote (append (cdar x) d))))
-;;           (quasiquote-expand (cdr x))))
-;;         (else
-;;          (core:display "ELSje\n")
-;;          (core:display "CAR x=") (core:display (car x))
-;;          (core:display "\n")
-;;          (core:display "CDR x=") (core:display (cdr x))
-;;          (core:display "\n")
-;;          ((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))
-;;                         (list 'quote (cons (cadr a) (cadr d)))
-;;                         (if (null? (cadr d))
-;;                             (list 'list a)
-;;                             (list 'cons* a d)))
-;;                     (if (memq (car d) '(list cons*))
-;;                         (cons (car d) (cons a (cdr d)))
-;;                         (list 'cons* a d)))
-;;                 (list 'cons* a d)))
-;;           (quasiquote-expand (car x))
-;;           (list 'quasiquote-expand (list 'cdr x))))))
-
 (define (caar x) (car (car x)))
 (define (cadr x) (car (cdr x)))
 (define (cdar x) (cdr (car x)))
@@ -111,7 +66,8 @@
 (define (quasiquote-expand x)
   (core:display "quasiquote-expand x=") (core:display x) (core:display "\n")
   (cond ((vector? x) (list 'list->vector (quasiquote-expand (vector->list x))))
-        ((not (pair? x)) (cons 'quote (cons x '())))
+        ((not (pair? x))
+         (core:display "not pair!\n") (cons 'quote (cons x '())))
         ((eq? (car x) 'quasiquote) (quasiquote-expand (quasiquote-expand
                                              (if (null? (cddr x)) (cadr x)
                                                  (cons 'list (cdr x))))))
@@ -124,14 +80,15 @@
           (quasiquote-expand (cdr x))))
         (else
          (core:display "ELSje\n")
+         (core:display "x=") (core:display x) (core:display "\n")
          (core:display "CAR x=") (core:display (car x))
          (core:display "\n")
          (core:display "CDR x=") (core:display (cdr x))
          (core:display "\n")
          ((lambda (a d)
-            (core:display "CAR a=") (core:display a)
+            (core:display "a=") (core:display a)
             (core:display "\n")
-            (core:display "CDR d=") (core:display d)
+            (core:display "d=") (core:display d)
             (core:display "\n")
 
                  (if (pair? d)
@@ -146,17 +103,7 @@
                              (list 'cons* a d)))
                      (list 'cons* a d)))
                (quasiquote-expand (car x))
-               (quasiquote-expand (cdr x))
+               (quasiquote-expand (cdr x))))))
-))))
 
-(define-macro (quasiquote x)
-  (quasiquote-expand x))
-
-;; (define (remainder x y)
-;;   (- x (* (/ x y) y)))
-;; (define (even? x)
-;;   (eq? 0 (remainder x v2)))
-;; (pass-if-equal "qq 4" '#(10 5 #t #t #f #f #f 8)
-;;                `#(10 5 ,(even? 4) ,@(map even? '(2 3 5 7)) 8))
-;;(core:display (quasiquote #(42)))
 (core:display (quasiquote-expand #(42)))
+(core:display "\n")

scaffold/boot/4f-string-split.scm

@@ -35,21 +35,11 @@
 (define-macro (simple-let bindings . rest)
   (cons (cons 'lambda (cons (map car bindings) rest))
         (map cadr bindings)))
-
-;; (define-macro (xsimple-let bindings rest)
-;;   `(,`(lambda ,(map car bindings) ,@rest)
-;;     ,@(map cadr bindings)))
-
 (define-macro (xsimple-let bindings rest)
   (cons* (cons* (quote lambda)
                 (map car bindings) (append2 rest (quote ())))
          (append2 (map cadr bindings) (quote ()))))
 
-;; (define-macro (xnamed-let name bindings rest)
-;;   `(simple-let ((,name *unspecified*))
-;;      (set! ,name (lambda ,(map car bindings) ,@rest))
-;;      (,name ,@(map cadr bindings))))
-
 (define-macro  (xnamed-let name bindings rest)
   (list (quote simple-let)
         (list (cons* name (quote (*unspecified*))))
@@ -60,11 +50,6 @@
                      (append2 rest (quote ()))))
         (cons* name (append2 (map cadr bindings) (quote ())))))
 
-;; (define-macro (let bindings-or-name . rest)
-;;   (if (symbol? bindings-or-name)
-;;       `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
-;;       `(xsimple-let ,bindings-or-name ,rest)))
-
 (define-macro (let bindings-or-name . rest)
   (if (symbol? bindings-or-name) (list (quote xnamed-let) bindings-or-name (car rest) (cdr rest))
       (list (quote xsimple-let) bindings-or-name rest)))
@@ -84,13 +69,6 @@
   (if (= 0 n) '()
       (cons (car x) (ss-list-head (cdr x) (- n 1)))))
 
-;; (define (foo x y)
-;;   (cons x y))
-
-;; (define (ss-list-head x n)
-;;   (if (= 0 n) '()
-;;       (foo (car x) (ss-list-head (cdr x) (- n 1)))))
-
 (define (string->list s)
   (core:car s))
 

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 (core:car (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)))
@@ -139,21 +139,13 @@
       (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)
@@ -163,12 +155,6 @@
   (define (vector? x)
     (eq? (core:type x) <cell:vector>))
 
-  ;; (define (body x)
-  ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
-  ;; (define (closure x)
-  ;;   (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
-  ;; ))
-
 (define (cons* . rest)
   (if (null? (cdr rest)) (car rest)
       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
@@ -183,9 +169,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)))
@@ -560,5 +544,3 @@
                         (if (not condition)
                             (begin exp ...))))))
    (xwhen #f 42)))
-
-

scaffold/boot/60-let-syntax.scm

@@ -52,20 +52,12 @@
       (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>))
@@ -73,12 +65,6 @@
   (define (vector? x)
     (eq? (core:type x) <cell:vector>))
 
-  ;; (define (body x)
-  ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
-  ;; (define (closure x)
-  ;;   (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
-  ;; ))
-
 (define (cons* . rest)
   (if (null? (cdr rest)) (car rest)
       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
@@ -93,9 +79,7 @@
           (append2 (car rest) (apply append (cdr rest))))))
 
 (define-macro (quasiquote x)
-  ;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
   (define (loop x)
-    ;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
     (if (vector? x) (list 'list->vector (loop (vector->list x)))
         (if (not (pair? x)) (cons 'quote (cons x '()))
             (if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
@@ -470,4 +454,3 @@
                         (if (not condition)
                             (begin exp ...))))))
    (xwhen #f 42)))
-

src/gc.c

@@ -70,7 +70,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++)

src/hash.c

@@ -0,0 +1,146 @@
+/* -*-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
+char_hash (int c)
+{
+  if (c >= 'a' && c <= 'z')
+    return c - 'a';
+  return 27;
+}
+
+int
+hashq_ (SCM x, long size)
+{
+  int hash = char_hash (VALUE (CAR (STRING (x)))) * 27;
+  if (TYPE (CDR (STRING (x))) == TPAIR)
+    hash = hash + char_hash (VALUE (CADR (STRING (x))));
+  else
+    hash = hash + char_hash (0);
+  assert (hash <= 756);
+  return hash;
+}
+
+int
+hashq (SCM x, SCM size)
+{
+  return hashq_ (x, VALUE (size));
+}
+
+SCM
+hashq_ref (SCM table, SCM key, SCM dflt)
+{
+  unsigned hash = hashq_ (key, 0);
+  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_set_x (SCM table, SCM key, SCM value)
+{
+  unsigned hash = hashq_ (key, 0);
+  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;
+}
+
+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)
+            {
+              display_ (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_name = cstring_to_symbol ("<record-type>");
+  SCM record_type = record_type_name; // FIXME
+  SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
+  SCM fields = cell_nil;
+  fields = cons (cstring_to_symbol ("buckets"), fields);
+  fields = cons (cstring_to_symbol ("size"), fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (hashq_type_name, fields);
+  return make_struct (record_type, fields, cell_unspecified);
+}
+
+SCM
+make_hash_table_ (long size)
+{
+  if (!size)
+    size = 30 * 27;
+  SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
+  SCM record_type_name = cstring_to_symbol ("<record-type>");
+  //SCM hashq_type = hashq_type_name; // FIXME
+  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 (hashq_type_name, 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

@@ -80,6 +80,8 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
   else if (t == TVARIABLE)
     {
       fdputs ("#<variable ", fd);
+      if (LOCAL_P (x))
+        fdputs ("*local* ", fd);
       display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
       fdputs (">", fd);
     }
@@ -166,11 +168,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);

src/mes.c

@@ -52,8 +52,10 @@ SCM r1 = 0;
 SCM r2 = 0;
 // continuation
 SCM r3 = 0;
+// current-module
+SCM m0 = 0;
 // macro
-SCM g_macros = 1;
+SCM g_macros = 0;
 SCM g_ports = 1;
 
 #if __M2_PLANET__
@@ -69,13 +71,14 @@ CONSTANT TPORT          8
 CONSTANT TREF           9
 CONSTANT TSPECIAL      10
 CONSTANT TSTRING       11
-CONSTANT TSYMBOL       12
+CONSTANT TSTRUCT       12
-CONSTANT TVALUES       13
+CONSTANT TSYMBOL       13
-CONSTANT TVARIABLE     14
+CONSTANT TVALUES       14
-CONSTANT TVECTOR       15
+CONSTANT TVARIABLE     15
-CONSTANT TBROKEN_HEART 16
+CONSTANT TVECTOR       16
+CONSTANT TBROKEN_HEART 17
 #else // !__M2_PLANET__
-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};
 #endif // !__M2_PLANET__
 
 typedef SCM (*function0_t) (void);
@@ -121,6 +124,7 @@ struct scm {
     long length;
   };
   union {
+    long local_p;
     long value;
     long function;
     long port;
@@ -180,6 +184,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};
@@ -252,6 +257,7 @@ 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};
@@ -274,19 +280,25 @@ int g_function = 0;
 
 #if !__GNUC__ || !_POSIX_SOURCE
 #include "gc.mes.h"
+#include "hash.mes.h"
 #include "lib.mes.h"
 #include "math.mes.h"
 #include "mes.mes.h"
+#include "module.mes.h"
 #include "posix.mes.h"
 #include "reader.mes.h"
+#include "struct.mes.h"
 #include "vector.mes.h"
 #else
 #include "gc.h"
+#include "hash.h"
 #include "lib.h"
 #include "math.h"
 #include "mes.h"
+#include "module.h"
 #include "posix.h"
 #include "reader.h"
+#include "struct.h"
 #include "vector.h"
 #endif
 
@@ -300,6 +312,7 @@ int g_function = 0;
 
 #if !_POSIX_SOURCE
 #define LENGTH(x) g_cells[x].car
+#define LOCAL_P(x) g_cells[x].cdr
 #define REF(x) g_cells[x].car
 #define STRING(x) g_cells[x].car
 #define VARIABLE(x) g_cells[x].car
@@ -311,6 +324,7 @@ int g_function = 0;
 #define FUNCTION0(x) g_functions[g_cells[x].cdr].function
 #define MACRO(x) g_cells[x].cdr
 #define PORT(x) g_cells[x].cdr
+#define STRUCT(x) g_cells[x].cdr
 #define VALUE(x) g_cells[x].cdr
 #define VECTOR(x) g_cells[x].cdr
 
@@ -320,8 +334,9 @@ int g_function = 0;
 #define NVECTOR(x) g_news[x].cdr
 
 #else
-#define CONTINUATION(x) g_cells[x].cdr
+#define CONTINUATION(x) g_cells[x].continuation
 #define HITS(x) g_cells[x].hits
+#define LOCAL_P(x) g_cells[x].local_p
 #define LENGTH(x) g_cells[x].length
 #define NAME(x) g_cells[x].name
 #define STRING(x) g_cells[x].string
@@ -331,6 +346,7 @@ int g_function = 0;
 #define MACRO(x) g_cells[x].macro
 #define PORT(x) g_cells[x].port
 #define REF(x) g_cells[x].ref
+#define STRUCT(x) g_cells[x].vector
 #define VALUE(x) g_cells[x].value
 #define VECTOR(x) g_cells[x].vector
 #define FUNCTION(x) g_functions[g_cells[x].function]
@@ -409,7 +425,7 @@ list_of_char_equal_p (SCM a, SCM b) ///((internal))
 }
 
 SCM
-lookup_symbol_ (SCM s)
+list_to_symbol (SCM s)
 {
   SCM x = g_symbols;
   while (x)
@@ -447,6 +463,7 @@ cdr_ (SCM x)
 {
   return (TYPE (x) != TCHAR
           && TYPE (x) != TNUMBER
+          && TYPE (x) != TPORT
           && (TYPE (CDR (x)) == TPAIR
               || TYPE (CDR (x)) == TREF
               || TYPE (CDR (x)) == TSPECIAL
@@ -553,7 +570,7 @@ error (SCM key, SCM x)
 {
 #if !__MESC_MES__
   SCM throw;
-  if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
+  if ((throw = module_ref (r0, cell_symbol_throw)) != cell_undefined)
     return apply (throw, cons (key, cons (x, cell_nil)), r0);
 #endif
   display_error_ (key);
@@ -578,6 +595,12 @@ cstring_to_list (char const* s)
   return string_to_list (s, strlen (s));
 }
 
+SCM
+cstring_to_symbol (char const *s)
+{
+  return list_to_symbol (cstring_to_list (s));
+}
+
 //  extra lib
 SCM
 assert_defined (SCM x, SCM e) ///((internal))
@@ -625,6 +648,8 @@ check_apply (SCM f, SCM e) ///((internal))
     type = "number";
   if (TYPE (f) == TSTRING)
     type = "string";
+  if (TYPE (f) == TSTRUCT)
+    type = "#<...>";
   if (TYPE (f) == TBROKEN_HEART)
     type = "<3";
 
@@ -645,7 +670,7 @@ check_apply (SCM f, SCM e) ///((internal))
 SCM
 gc_push_frame () ///((internal))
 {
-  SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
+  SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cons (m0, cell_nil)))));
   g_stack = cons (frame, g_stack);
   return g_stack;
 }
@@ -809,15 +834,6 @@ assq (SCM x, SCM a)
   return a != cell_nil ? CAR (a) : cell_f;
 }
 
-SCM
-assq_ref_env (SCM x, SCM a)
-{
-  x = assq (x, a);
-  if (x == cell_f)
-    return cell_undefined;
-  return CDR (x);
-}
-
 SCM
 set_car_x (SCM x, SCM e)
 {
@@ -842,19 +858,25 @@ set_env_x (SCM x, SCM e, SCM a)
   SCM p;
   if (TYPE (x) == TVARIABLE)
     p = VARIABLE (x);
-  else
+  if (TYPE (x) == TSYMBOL)
-    p = assert_defined (x, assq (x, a));
+    p = assert_defined (x, module_variable (a, x));
+  if (TYPE (p) == TVARIABLE)
+    p = VARIABLE (p);
   if (TYPE (p) != TPAIR)
     error (cell_symbol_not_a_pair, cons (p, x));
   return set_cdr_x (p, e);
 }
 
+SCM expand_variable (SCM x, SCM formals, int global_p); // MOEFMIE
+
 SCM
-call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
+call_lambda (SCM e, SCM formals, SCM a) ///((internal))
 {
-  SCM cl = cons (cons (cell_closure, x), x);
+  SCM cl = cons (cons (cell_closure, a), a);
   r1 = e;
   r0 = cl;
+  expand_variable (e, formals, 0);
+  r0 = cl;
   return cell_unspecified;
 }
 
@@ -865,22 +887,38 @@ make_closure_ (SCM args, SCM body, SCM a) ///((internal))
 }
 
 SCM
-make_variable_ (SCM var) ///((internal))
+make_variable_ (SCM var, int local_p) ///((internal))
 {
-  return make_cell__ (TVARIABLE, var, 0);
+  return make_cell__ (TVARIABLE, var, local_p);
+}
+
+// SCM
+// make_variable (SCM var, SCM local_p)
+// {
+//   return make_variable_ (var, VALUE (local_p));
+// }
+
+SCM
+macro_ref (SCM table, SCM name) ///((internal))
+{
+  return hashq_ref (table, name, cell_nil);
 }
 
 SCM
-lookup_macro_ (SCM x, SCM a) ///((internal))
+get_macro (SCM table, SCM name) ///((internal))
 {
-  if (TYPE (x) != TSYMBOL)
+  SCM m = macro_ref (table, name);
-    return cell_f;
-  SCM m = assq (x, a);
   if (m != cell_f)
     return MACRO (CDR (m));
   return cell_f;
 }
 
+SCM
+macro_set_x (SCM table, SCM name, SCM value) ///((internal))
+{
+  return hashq_set_x (table, name, value);
+}
+
 SCM
 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
 {
@@ -889,7 +927,10 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
   r2 = p2;
   gc_push_frame ();
   r1 = p1;
-  r0 = a;
+  // if (TYPE (a) == TPAIR)
+  //   r0 = module_clone_locals (r0, a);
+  // else
+    r0 = a;
   r3 = x;
   return cell_unspecified;
 }
@@ -902,6 +943,7 @@ gc_peek_frame () ///((internal))
   r2 = CADR (frame);
   r3 = CAR (CDDR (frame));
   r0 = CADR (CDDR (frame));
+  m0 = CAR (CDDR (CDDR (frame)));
   return frame;
 }
 
@@ -945,30 +987,42 @@ formal_p (SCM x, SCM formals) /// ((internal))
 }
 
 SCM
-expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
+expand_variable_ (SCM x, SCM formals, int global_p, int top_p) ///((internal))
 {
   while (TYPE (x) == TPAIR)
     {
+      if (g_debug > 2)
+        {
+          eputs ("expand x=");
+          display_error_ (x);
+          eputs ("\n");
+        }
       if (TYPE (CAR (x)) == TPAIR)
         {
           if (CAAR (x) == cell_symbol_lambda)
             {
+              if (!global_p)
+                return cell_unspecified;
               SCM f = CAR (CDAR (x));
               formals = add_formals (formals, f);
             }
           else if (CAAR (x) == cell_symbol_define
                    || CAAR (x) == cell_symbol_define_macro)
             {
+              if (!global_p)
+                return cell_unspecified;
               SCM f = CAR (CDAR (x));
               formals = add_formals (formals, f);
             }
           if (CAAR (x) != cell_symbol_quote)
-            expand_variable_ (CAR (x), formals, 0);
+            expand_variable_ (CAR (x), formals, global_p, 0);
         }
       else
         {
           if (CAR (x) == cell_symbol_lambda)
             {
+              if (!global_p)
+                return cell_unspecified;
               SCM f = CADR (x);
               formals = add_formals (formals, f);
               x = CDR (x);
@@ -976,6 +1030,8 @@ expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
           else if (CAR (x) == cell_symbol_define
                    || CAR (x) == cell_symbol_define_macro)
             {
+              if (!global_p)
+                return cell_unspecified;
               SCM f = CADR (x);
               if (top_p && TYPE (f) == TPAIR)
                 f = CDR (f);
@@ -984,17 +1040,49 @@ expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
             }
           else if (CAR (x) == cell_symbol_quote)
             return cell_unspecified;
+          else if (TYPE (CAR (x)) == TVARIABLE && LOCAL_P (CAR (x)))
+            {
+              SCM n = CAR (VARIABLE (CAR (x)));
+              if (g_debug > 2)
+                {
+                  eputs ("local_p: "); display_error_ (CAR (x)); eputs ("\n");
+                }
+              SCM v = module_variable (r0, n);
+              if (g_debug > 2)
+                {
+                  eputs (" ==>: "); display_error_ (v); eputs ("\n");
+                }
+              if (v == cell_f && g_debug > 2)
+                {
+                  eputs ("local_p: "); display_error_ (CAR (x)); eputs ("\n");
+                  exit (22);
+                }
+              //if (v == cell_f || formal_p (n, formals))
+              //if (v == cell_f)
+              //v = n;
+              CAR (x) = v;
+            }
+          else if (TYPE (CAR (x)) == TVARIABLE)
+            {
+              if (g_debug > 2)
+                {
+                  eputs ("global: "); display_error_ (CAR (x)); eputs ("\n");
+                }
+            }
           else if (TYPE (CAR (x)) == TSYMBOL
-                   && CAR (x) != cell_begin
+                   && CAR (x) != cell_symbol_boot_module
-                   && CAR (x) != cell_symbol_begin
                    && CAR (x) != cell_symbol_current_module
                    && CAR (x) != cell_symbol_primitive_load
-                   && CAR (x) != cell_symbol_if // HMM
                    && !formal_p (CAR (x), formals))
             {
-              SCM v = assq (CAR (x), r0);
+              SCM v = module_variable (r0, CAR (x));
-              if (v != cell_f)
+              if (g_debug > 1 && v != cell_f)
-                CAR (x) = make_variable_ (v);
+                {
+                  eputs ("expanding: "); display_error_ (v); eputs ("\n");
+                }
+              if (v != cell_f && (!LOCAL_P (v) || !global_p))  // local expand!
+              //if (v != cell_f && !LOCAL_P (v)) // no local expand: works
+                CAR (x) = v;
             }
         }
       x = CDR (x);
@@ -1004,11 +1092,14 @@ expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
 }
 
 SCM
-expand_variable (SCM x, SCM formals) ///((internal))
+expand_variable (SCM x, SCM formals, int global_p) ///((internal))
 {
-  return expand_variable_ (x, formals, 1);
+  return expand_variable_ (x, formals, global_p, 1);
 }
 
+SCM struct_ref_ (SCM x, long i);
+SCM vector_ref_ (SCM x, long i);
+
 SCM
 eval_apply ()
 {
@@ -1025,6 +1116,7 @@ eval_apply ()
   SCM p;
   SCM program;
   SCM sc_expand;
+  SCM v;
   SCM x;
   int global_p;
   int macro_p;
@@ -1102,7 +1194,7 @@ eval_apply ()
       aa = CDR (aa);
       check_formals (CAR (r1), formals, CDR (r1));
       p = pairlis (formals, args, aa);
-      call_lambda (body, p, aa, r0);
+      call_lambda (body, formals, p);
       goto begin;
     }
   else if (t == TCONTINUATION)
@@ -1151,6 +1243,11 @@ eval_apply ()
           r1 = r0;
           goto vm_return;
         }
+      if (CAR (r1) == cell_symbol_boot_module)
+        {
+          r1 = m0;
+          goto vm_return;
+        }
     }
   else if (t == TPAIR)
     {
@@ -1161,7 +1258,7 @@ eval_apply ()
           body = CDDR (CAR (r1));
           p = pairlis (formals, CDR (r1), r0);
           check_formals (r1, formals, args);
-          call_lambda (body, p, p, r0);
+          call_lambda (body, formals, p);
           goto begin;
         }
     }
@@ -1251,21 +1348,13 @@ eval_apply ()
                     {
                       entry = assq (name, g_macros);
                       if (entry == cell_f)
-                        {
+                        macro_set_x (g_macros, name, cell_f);
-                          entry = cons (name, cell_f);
-                          g_macros = cons (entry, g_macros);
-                        }
                     }
                   else
                     {
-                      entry = assq (name, r0);
+                      entry = module_variable (r0, name);
                       if (entry == cell_f)
-                        {
+                        module_define_x (m0, name, cell_f);
-                          entry = cons (name, cell_f);
-                          aa = cons (entry, cell_nil);
-                          set_cdr_x (aa, cdr (r0));
-                          set_cdr_x (r0, aa);
-                        }
                     }
                 }
               r2 = r1;
@@ -1281,7 +1370,7 @@ eval_apply ()
                   body = CDDR (r1);
 
                   if (macro_p || global_p)
-                    expand_variable (body, formals);
+                    expand_variable (body, formals, 1);
                   r1 = cons (cell_symbol_lambda, cons (formals, body));
                   push_cc (r1, r2, p, cell_vm_eval_define);
                   goto eval;
@@ -1292,13 +1381,14 @@ eval_apply ()
                 name = CAR (name);
               if (macro_p)
                 {
-                  entry = assq (name, g_macros);
+                  entry = macro_ref (g_macros, name);
                   r1 = MAKE_MACRO (name, r1);
                   set_cdr_x (entry, r1);
                 }
               else if (global_p)
                 {
-                  entry = assq (name, r0);
+                  v = module_variable (r0, name);
+                  entry = VARIABLE (v);
                   set_cdr_x (entry, r1);
                 }
               else
@@ -1307,7 +1397,8 @@ eval_apply ()
                   aa = cons (entry, cell_nil);
                   set_cdr_x (aa, cdr (r0));
                   set_cdr_x (r0, aa);
-                  cl = assq (cell_closure, r0);
+                  v = module_variable (r0, cell_closure);
+                  cl = VARIABLE (v);
                   set_cdr_x (cl, aa);
                 }
               r1 = cell_unspecified;
@@ -1326,6 +1417,8 @@ eval_apply ()
     }
   else if (t == TSYMBOL)
     {
+      if (r1 == cell_symbol_boot_module)
+        goto vm_return;
       if (r1 == cell_symbol_current_module)
         goto vm_return;
       if (r1 == cell_symbol_begin) // FIXME
@@ -1333,7 +1426,7 @@ eval_apply ()
           r1 = cell_begin;
           goto vm_return;
         }
-      r1 = assert_defined (r1, assq_ref_env (r1, r0));
+      r1 = assert_defined (r1, module_ref (r0, r1));
       goto vm_return;
     }
   else if (t == TVARIABLE)
@@ -1348,9 +1441,6 @@ eval_apply ()
 
  macro_expand:
   {
-    macro;
-    expanders;
-
     if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
       goto vm_return;
 
@@ -1365,7 +1455,7 @@ eval_apply ()
       }
 
     if (TYPE (r1) == TPAIR
-        && (macro = lookup_macro_ (CAR (r1), g_macros)) != cell_f)
+        && (macro = get_macro (g_macros, CAR (r1))) != cell_f)
       {
         r1 = cons (macro, CDR (r1));
         push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
@@ -1403,11 +1493,11 @@ eval_apply ()
     if (TYPE (r1) == TPAIR
         && TYPE (CAR (r1)) == TSYMBOL
         && CAR (r1) != cell_symbol_begin
-        && ((macro = assq (cell_symbol_portable_macro_expand, g_macros)) != cell_f)
+        && ((macro = macro_ref (g_macros, cell_symbol_portable_macro_expand)) != cell_f)
-        && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
+        && ((expanders = module_ref (r0, cell_symbol_sc_expander_alist)) != cell_undefined)
         && ((macro = assq (CAR (r1), expanders)) != cell_f))
       {
-        sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
+        sc_expand = module_ref (r0, cell_symbol_macro_expand);
         r2 = r1;
         if (sc_expand != cell_undefined && sc_expand != cell_f)
           {
@@ -1499,6 +1589,8 @@ eval_apply ()
 
               push_cc (input, r2, r0, cell_vm_return);
               x = read_input_file_env (r0);
+              if (g_debug > 3)
+                module_printer (m0);
               gc_pop_frame ();
               input = r1;
               r1 = x;
@@ -1520,7 +1612,7 @@ eval_apply ()
           continue;
         }
       r1 = r2;
-      expand_variable (CAR (r1), cell_nil);
+      expand_variable (CAR (r1), cell_nil, 1);
       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
       goto eval;
     begin_expand_eval:
@@ -1586,16 +1678,18 @@ apply (SCM f, SCM x, SCM a) ///((internal))
 SCM
 mes_g_stack (SCM a) ///((internal))
 {
-  r0 = a;
+  //r0 = a;
   r1 = MAKE_CHAR (0);
   r2 = MAKE_CHAR (0);
   r3 = MAKE_CHAR (0);
   g_stack = cons (cell_nil, cell_nil);
-  return r0;
+  return a;
 }
 
 // Environment setup
 
+#include "hash.c"
+#include "module.c"
 #include "posix.c"
 #include "math.c"
 #include "lib.c"
@@ -1721,6 +1815,9 @@ g_cells[cell_call_with_current_continuation] = scm_call_with_current_continuatio
 g_free++;
 g_cells[cell_symbol_call_with_current_continuation] = scm_symbol_call_with_current_continuation;
 
+g_free++;
+g_cells[cell_symbol_boot_module] = scm_symbol_boot_module;
+
 g_free++;
 g_cells[cell_symbol_current_module] = scm_symbol_current_module;
 
@@ -1942,6 +2039,7 @@ g_cells[cell_symbol_sc_expander_alist].car = cstring_to_list (scm_symbol_sc_expa
 g_cells[cell_symbol_call_with_values].car = cstring_to_list (scm_symbol_call_with_values.name);
 g_cells[cell_call_with_current_continuation].car = cstring_to_list (scm_call_with_current_continuation.name);
 g_cells[cell_symbol_call_with_current_continuation].car = cstring_to_list (scm_symbol_call_with_current_continuation.name);
+g_cells[cell_symbol_boot_module].car = cstring_to_list (scm_symbol_boot_module.name);
 g_cells[cell_symbol_current_module].car = cstring_to_list (scm_symbol_current_module.name);
 g_cells[cell_symbol_primitive_load].car = cstring_to_list (scm_symbol_primitive_load.name);
 g_cells[cell_symbol_read_input_file].car = cstring_to_list (scm_symbol_read_input_file.name);
@@ -2010,12 +2108,42 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
 #endif
 
   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
+  a = acons (cell_symbol_boot_module, cell_symbol_boot_module, a);
   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
 
   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
 
+  a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
+  a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
+  a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
+  a = acons (cell_type_function, MAKE_NUMBER (TFUNCTION), a);
+  a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a);
+  a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a);
+  a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a);
+  a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a);
+  a = acons (cell_type_port, MAKE_NUMBER (TPORT), a);
+  a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
+  a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
+  a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
+  a = acons (cell_type_struct, MAKE_NUMBER (TSTRUCT), a);
+  a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
+  a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
+  a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
+  a = acons (cell_type_vector, MAKE_NUMBER (TVECTOR), a);
+  a = acons (cell_type_broken_heart, MAKE_NUMBER (TBROKEN_HEART), a);
+
+  a = acons (cell_closure, a, a);
+
+  return a;
+}
+
+SCM
+mes_environment (int argc, char *argv[])
+{
+  SCM a = mes_symbols ();
+
   char *compiler = "gnuc";
 #if __MESC__
   compiler = "mesc";
@@ -2030,33 +2158,13 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
 #endif
   a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
 
-  a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
+#if !MES_MINI
-  a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
+  SCM lst = cell_nil;
-  a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
+  for (int i=argc-1; i>=0; i--)
-  a = acons (cell_type_function, MAKE_NUMBER (TFUNCTION), a);
+    lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
-  a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a);
+  a = acons (cell_symbol_argv, lst, a);
-  a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a);
+#endif
-  a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a);
-  a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a);
-  a = acons (cell_type_port, MAKE_NUMBER (TPORT), a);
-  a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
-  a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
-  a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
-  a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
-  a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
-  a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
-  a = acons (cell_type_vector, MAKE_NUMBER (TVECTOR), a);
-  a = acons (cell_type_broken_heart, MAKE_NUMBER (TBROKEN_HEART), a);
 
-  a = acons (cell_closure, a, a);
-
-  return a;
-}
-
-SCM
-mes_environment () ///((internal))
-{
-  SCM a = mes_symbols ();
   return mes_g_stack (a);
 }
 
@@ -2191,37 +2299,49 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
 #include "mes.mes.i"
 
   // Do not sort: Order of these includes define builtins
+#include "hash.mes.i"
+#include "module.mes.i"
 #include "posix.mes.i"
 #include "math.mes.i"
 #include "lib.mes.i"
 #include "vector.mes.i"
+#include "struct.mes.i"
 #include "gc.mes.i"
 #include "reader.mes.i"
 
 #include "gc.mes.environment.i"
+#include "hash.mes.environment.i"
 #include "lib.mes.environment.i"
 #include "math.mes.environment.i"
 #include "mes.mes.environment.i"
+#include "module.mes.environment.i"
 #include "posix.mes.environment.i"
 #include "reader.mes.environment.i"
+#include "struct.mes.environment.i"
 #include "vector.mes.environment.i"
 #else
 #include "mes.i"
 
   // Do not sort: Order of these includes define builtins
+#include "hash.i"
+#include "module.i"
 #include "posix.i"
 #include "math.i"
 #include "lib.i"
 #include "vector.i"
+#include "struct.i"
 #include "gc.i"
 #include "reader.i"
 
 #include "gc.environment.i"
+#include "hash.environment.i"
 #include "lib.environment.i"
 #include "math.environment.i"
 #include "mes.environment.i"
+#include "module.environment.i"
 #include "posix.environment.i"
 #include "reader.environment.i"
+#include "struct.environment.i"
 #include "vector.environment.i"
 #endif
 
@@ -2269,9 +2389,8 @@ load_boot (char *prefix, char const *boot, char const *location)
 }
 
 SCM
-load_env (SCM a) ///((internal))
+load_env () ///((internal))
 {
-  r0 = a;
   g_stdin = -1;
   char prefix[1024];
   char boot[1024];
@@ -2310,15 +2429,13 @@ load_env (SCM a) ///((internal))
       exit (1);
     }
 
-  if (!g_function)
-    r0 = mes_builtins (r0);
   r2 = read_input_file_env (r0);
   g_stdin = STDIN;
   return r2;
 }
 
 SCM
-bload_env (SCM a) ///((internal))
+bload_env () ///((internal))
 {
 #if !_POSIX_SOURCE
   char *mo = "mes/boot-0.32-mo";
@@ -2358,23 +2475,11 @@ bload_env (SCM a) ///((internal))
   gc_peek_frame ();
   g_symbols = r1;
   g_stdin = STDIN;
+  // SCM a = struct_ref (r0, 4);
+  // a = mes_builtins (a);
+  // struct_set_x (r0, 4, a);
   r0 = mes_builtins (r0);
 
-  char *compiler = "gnuc";
-#if __MESC__
-  compiler = "mesc";
-#elif __TINYC__
-  compiler = "tcc";
-#endif
-
-  a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a);
-
-  char *arch = "x86";
-#if __x86_64__
-  arch = "x86_64";
-#endif
-  a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
-
   if (g_debug > 3)
     {
       eputs ("symbols: ");
@@ -2402,6 +2507,7 @@ bload_env (SCM a) ///((internal))
 }
 
 #include "vector.c"
+#include "struct.c"
 #include "gc.c"
 #include "reader.c"
 
@@ -2429,21 +2535,21 @@ main (int argc, char *argv[])
     GC_SAFETY = atoi (p);
   g_stdin = STDIN;
   g_stdout = STDOUT;
-  r0 = mes_environment ();
+
+  SCM a = mes_environment (argc, argv);
+  a = mes_builtins (a);
+  m0 = make_initial_module (a);
+  g_macros = make_hash_table_ (0);
+
+  if (g_debug > 3)
+    module_printer (m0);
 
   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
-    ? bload_env (r0) : load_env (r0);
+    ? bload_env () : load_env ();
   g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
   if (argc > 1 && !strcmp (argv[1], "--dump"))
     return dump ();
 
-#if !MES_MINI
-  SCM lst = cell_nil;
-  for (int i=argc-1; i>=0; i--)
-    lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
-  r0 = acons (cell_symbol_argv, lst, r0); // FIXME
-  r0 = acons (cell_symbol_argv, lst, r0);
-#endif
   push_cc (r2, cell_unspecified, r0, cell_unspecified);
 
   if (g_debug > 2)

src/module.c

@@ -0,0 +1,134 @@
+/* -*-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_name = cstring_to_symbol ("<record-type>");
+  SCM record_type = record_type_name; // FIXME
+  SCM module_type_name = cstring_to_symbol ("<module>");
+  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 (module_type_name, fields);
+  return make_struct (record_type, fields, cell_unspecified);
+}
+
+SCM
+make_initial_module (SCM a) ///((internal))
+{
+  SCM module_type_name = cstring_to_symbol ("<module>");
+  // SCM module_type = module_type_name; //FIXME
+  SCM module_type = make_module_type ();
+  a = acons (module_type_name, module_type, a);
+
+  SCM hashq_type = make_hashq_type ();
+  SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
+  a = acons (hashq_type_name, 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 (module_type_name, 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="); display_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)
+{
+  if (g_debug > 4)
+    {
+      eputs ("module_variable: "); display_error_ (name); eputs ("\n");
+    }
+  //SCM locals = struct_ref_ (module, 3);
+  SCM locals = module;
+  SCM x = assq (name, locals);
+  if (x != cell_f)
+      x = make_variable_ (x, 1);
+  else
+    {
+      module = m0;
+      SCM globals = struct_ref_ (module, 5);
+      x = hashq_ref (globals, name, cell_f);
+      if (x != cell_f)
+        x = make_variable_ (x, 0);
+    }
+  return x;
+}
+
+SCM
+module_ref (SCM module, SCM name)
+{
+  SCM x = module_variable (module, name);
+  if (x == cell_f)
+    return cell_undefined;
+  x = VARIABLE (x);
+  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/reader.c

@@ -34,8 +34,9 @@ read_input_file_env_ (SCM e, SCM a)
 SCM
 read_input_file_env (SCM a)
 {
-  r0 = a;
+  //r0 = a;
-  return read_input_file_env_ (read_env (r0), r0);
+  //return read_input_file_env_ (read_env (r0), r0);
+  return read_input_file_env_ (read_env (cell_nil), cell_nil);
 }
 
 int
@@ -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));
+  assert (i < LENGTH (x));
-  SCM e = VECTOR (x) + VALUE (i);
+  SCM e = VECTOR (x) + i;
   if (TYPE (e) == TREF)
     e = REF (e);
   if (TYPE (e) == TCHAR)
@@ -56,6 +56,12 @@ vector_ref (SCM x, SCM i)
   return e;
 }
 
+SCM
+vector_ref (SCM x, SCM i)
+{
+  return vector_ref_ (x, VALUE (i));
+}
+
 SCM
 vector_entry (SCM x)
 {
@@ -65,14 +71,20 @@ vector_entry (SCM x)
 }
 
 SCM
-vector_set_x (SCM x, SCM i, SCM e)
+vector_set_x_ (SCM x, long i, SCM e)
 {
   assert (TYPE (x) == TVECTOR);
-  assert (VALUE (i) < LENGTH (x));
+  assert (i < LENGTH (x));
-  g_cells[VECTOR (x)+VALUE (i)] = g_cells[vector_entry (e)];
+  g_cells[VECTOR (x)+i] = g_cells[vector_entry (e)];
   return cell_unspecified;
 }
 
+SCM
+vector_set_x (SCM x, SCM i, SCM e)
+{
+  return vector_set_x_ (x, VALUE (i), e);
+}
+
 SCM
 list_to_vector (SCM x)
 {

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

tests/srfi-0.test

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