merge mes-m2. WIP

* scripts/m2-merge.scm.in: New file.
* configure: Substitute it.
* .gitignore: Update.

.gitignore

@@ -147,6 +147,7 @@
 /install.sh
 /uninstall.sh
 /mes/module/mes/boot-0.scm
+/scripts/m2-merge.scm
 /scripts/mesar
 /scripts/mescc.scm
 /scripts/mescc
@@ -169,3 +170,8 @@
 /body-hello-mes
 /exit-42
 /hello-mes
+
+/lib/*/*.im
+/lib/*/*.m
+/src/*.im
+/src/*.m

build-aux/bootstrap.sh.in

@@ -20,8 +20,11 @@
 
 LANG=
 MES_ARENA=${MES_ARENA-100000000}
-MES_MAX_ARENA=${MES_MAX_ARENA-100000000}
-MES_STACK=${MES_STACK-500000}
+export MES_ARENA
+MES_MAX_ARENA=${MES_MAX_ARENA-${MES_ARENA}}
+export MES_MAX_ARENA
+MES_STACK=${MES_STACK-10000000}
+export MES_STACK
 
 . build-aux/configure-lib.sh
 
@@ -81,3 +84,15 @@ for c in $mes_SOURCES; do
 done
 echo "CCLD       src/mes"
 $CC -nostdlib -o src/mes -L mescc-lib mescc-lib/crt1.o $objects -lc
+
+(
+    mkdir -p gcc-lib
+    cp config.sh gcc-lib
+    cd gcc-lib
+    compiler=gcc
+    if test -z "$srcdest"; then
+        srcdest=../
+        srcdir=../
+    fi
+    @SHELL@ ${srcdest}build-aux/build-source-lib.sh
+)

build-aux/build-lib.sh

@@ -79,26 +79,3 @@ cp libgetopt.a $mes_cpu-mes
 if test -e libgetopt.s; then
     cp libgetopt.s $mes_cpu-mes
 fi
-
-cp ${srcdest}lib/$mes_kernel/$mes_cpu-mes-$compiler/crt*.c $mes_cpu-mes
-
-rm -f libc+gnu.c
-cat > libc+gnu.c <<EOF
-// Generated from Mes -- do not edit
-// compiler: $compiler
-// cpu:      $mes_cpu
-// bits:     $mes_bits
-// libc:     $mes_libc
-// kernel:   $mes_kernel
-// system:   $mes_system
-
-EOF
-for c in $libc_gnu_SOURCES; do
-    echo "// $c" >> libc+gnu.c
-    cat ${srcdest}$c >> libc+gnu.c
-    echo >> libc+gnu.c
-done
-cp libc+gnu.c $mes_cpu-mes
-
-cp ${srcdest}lib/libtcc1.c $mes_cpu-mes
-cp ${srcdest}lib/posix/getopt.c $mes_cpu-mes/libgetopt.c

build-aux/build-mes.sh

@@ -35,13 +35,17 @@ trap 'test -f .log && cat .log' EXIT
 
 srcdest=${srcdest-}
 mes_sources="
+src/builtins.c
+src/eval.c
 src/gc.c
+src/init.c
 src/hash.c
 src/lib.c
 src/math.c
 src/mes.c
 src/module.c
 src/posix.c
+src/printer.c
 src/reader.c
 src/string.c
 src/struct.c

build-aux/build-source-lib.sh

@@ -0,0 +1,53 @@
+#! /bin/sh
+
+# GNU Mes --- Maxwell Equations of Software
+# Copyright © 2019 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
+
+if test "$V" = 2; then
+    set -x
+fi
+
+set -u
+srcdest=${srcdest-}
+. ${srcdest}build-aux/configure-lib.sh
+
+mkdir -p $mes_cpu-mes
+cp ${srcdest}lib/$mes_kernel/$mes_cpu-mes-$compiler/crt*.c $mes_cpu-mes
+
+rm -f libc+gnu.c
+cat > libc+gnu.c <<EOF
+// Generated from Mes -- do not edit
+// compiler: $compiler
+// cpu:      $mes_cpu
+// bits:     $mes_bits
+// libc:     $mes_libc
+// kernel:   $mes_kernel
+// system:   $mes_system
+
+EOF
+for c in $libc_gnu_SOURCES; do
+    echo "// $c" >> libc+gnu.c
+    cat ${srcdest}$c >> libc+gnu.c
+    echo >> libc+gnu.c
+done
+cp libc+gnu.c $mes_cpu-mes
+
+cp ${srcdest}lib/libtcc1.c $mes_cpu-mes
+cp ${srcdest}lib/posix/getopt.c $mes_cpu-mes/libgetopt.c

build-aux/build.sh.in

@@ -87,15 +87,15 @@ export CPPFLAGS
 export LDFLAGS
 export LIBS
 
-if test $compiler = gcc; then
-    (
-        mkdir -p gcc-lib
-        cp config.sh gcc-lib
-        cd gcc-lib
-        if test -z "$srcdest"; then
-            srcdest=../
-            srcdir=../
-        fi
+(
+    mkdir -p gcc-lib
+    cp config.sh gcc-lib
+    cd gcc-lib
+    if test -z "$srcdest"; then
+        srcdest=../
+        srcdir=../
+    fi
+    if test $compiler = gcc; then
         CPPFLAGS="
 -D HAVE_CONFIG_H=1
 -I include
@@ -104,8 +104,9 @@ if test $compiler = gcc; then
 "
         ${SHELL} ${srcdest}build-aux/build-lib.sh
         cp crt1.o ..
-    )
-fi
+    fi
+    compiler=gcc ${SHELL} ${srcdest}build-aux/build-source-lib.sh
+)
 
 (
     if test $compiler = gcc; then
@@ -145,4 +146,5 @@ fi
     AR="${srcdest}pre-inst-env mesar"
     CC="${srcdest}pre-inst-env mescc -m $mes_bits"
     ${SHELL} ${srcdest}build-aux/build-lib.sh
+    ${SHELL} ${srcdest}build-aux/build-source-lib.sh
 )

build-aux/check-mescc.sh

@@ -200,12 +200,16 @@ if test -z "$bootstrap"; then
     TESTS="$TESTS
 lib/tests/dirent/90-readdir.c
 lib/tests/io/90-stat.c
+lib/tests/mes/90-abtod.c
+lib/tests/mes/90-dtoab.c
+lib/tests/posix/90-execlp.c
 lib/tests/posix/90-unsetenv.c
 lib/tests/signal/90-signal.c
 lib/tests/stdio/90-fopen.c
 lib/tests/stdio/90-fopen-append.c
 lib/tests/stdio/90-fread-fwrite.c
 lib/tests/stdio/90-fseek.c
+lib/tests/stdio/90-sprintf.c
 lib/tests/stdlib/90-strtol.c
 lib/tests/string/90-snprintf.c
 lib/tests/string/90-strpbrk.c
@@ -222,7 +226,7 @@ lib/tests/scaffold/a1-global-no-clobber.c
 fi
 
 XFAIL_TESTS="
-lib/tests/stdio/90-sprintf.c
+lib/tests/mes/90-abtod.c
 lib/tests/stdio/90-sprintf.c
 "
 
@@ -232,6 +236,7 @@ lib/tests/scaffold/17-compare-unsigned-char-le.c
 lib/tests/scaffold/17-compare-unsigned-short-le.c
 lib/tests/scaffold/66-local-char-array.c
 lib/tests/scaffold/72-typedef-struct-def-local.c
+lib/tests/mes/90-dtoab.c
 lib/tests/scaffold/90-goto-var.c
 lib/tests/scaffold/91-goto-array.c
 "
@@ -248,11 +253,6 @@ lib/tests/scaffold/a0-call-trunc-int.c
     fi
 fi
 
-if test $mes_cpu = x86; then
-    XFAIL_TESTS="$XFAIL_TESTS
-"
-fi
-
 if test $mes_cpu = x86_64; then
     XFAIL_TESTS="$XFAIL_TESTS
 lib/tests/stdio/70-printf-stdarg.c
@@ -261,6 +261,8 @@ fi
 
 if test $compiler = gcc; then
     XFAIL_TESTS="$XFAIL_TESTS
+lib/tests/mes/90-abtod.c
+lib/tests/mes/90-dtoab.c
 "
 
     if test $mes_cpu = x86; then

build-aux/configure-lib.sh

@@ -69,6 +69,10 @@ lib/mes/ntoab.c
 lib/mes/oputc.c
 lib/mes/ultoa.c
 lib/mes/utoa.c
+
+lib/m2/file_print.c
+lib/m2/numerate.c
+lib/m2/in_set.c
 "
 
 if test $mes_libc = mes; then
@@ -86,6 +90,8 @@ lib/linux/lseek.c
     fi
 else
     libmes_SOURCES="$libmes_SOURCES
+lib/mes/abtod.c
+lib/mes/dtoab.c
 "
 fi
 
@@ -156,6 +162,8 @@ lib/ctype/islower.c
 lib/ctype/isupper.c
 lib/ctype/tolower.c
 lib/ctype/toupper.c
+lib/mes/abtod.c
+lib/mes/dtoab.c
 lib/mes/search-path.c
 lib/posix/execvp.c
 lib/stdio/fclose.c
@@ -180,6 +188,7 @@ lib/stdio/vsprintf.c
 lib/stdio/vsscanf.c
 lib/stdlib/calloc.c
 lib/stdlib/qsort.c
+lib/stdlib/strtod.c
 lib/stdlib/strtof.c
 lib/stdlib/strtol.c
 lib/stdlib/strtold.c
@@ -199,7 +208,6 @@ lib/stub/ldexp.c
 lib/stub/mprotect.c
 lib/stub/localtime.c
 lib/stub/sigemptyset.c
-lib/stub/strtod.c
 lib/$mes_cpu-mes-$compiler/setjmp.c
 "
 
@@ -217,6 +225,7 @@ lib/ctype/isalnum.c
 lib/ctype/isalpha.c
 lib/ctype/isascii.c
 lib/ctype/iscntrl.c
+lib/ctype/isgraph.c
 lib/ctype/isprint.c
 lib/ctype/ispunct.c
 lib/dirent/__getdirentries.c
@@ -227,6 +236,7 @@ lib/math/fabs.c
 lib/mes/fdgets.c
 lib/posix/alarm.c
 lib/posix/execl.c
+lib/posix/execlp.c
 lib/posix/mktemp.c
 lib/posix/raise.c
 lib/posix/sbrk.c
@@ -243,6 +253,7 @@ lib/stdlib/abort.c
 lib/stdlib/abs.c
 lib/stdlib/alloca.c
 lib/stdlib/atexit.c
+lib/stdlib/atof.c
 lib/stdlib/atol.c
 lib/stdlib/mbstowcs.c
 lib/string/bcmp.c
@@ -263,14 +274,20 @@ lib/stub/ctime.c
 lib/stub/fpurge.c
 lib/stub/freadahead.c
 lib/stub/frexp.c
+lib/stub/getgrgid.c
+lib/stub/getgrnam.c
 lib/stub/getlogin.c
+lib/stub/getpgid.c
+lib/stub/getpgrp.c
 lib/stub/getpwnam.c
 lib/stub/getpwuid.c
 lib/stub/gmtime.c
+lib/stub/mktime.c
 lib/stub/pclose.c
 lib/stub/popen.c
 lib/stub/rand.c
 lib/stub/setbuf.c
+lib/stub/setgrent.c
 lib/stub/setlocale.c
 lib/stub/setvbuf.c
 lib/stub/sigaddset.c
@@ -303,14 +320,17 @@ lib/linux/kill.c
 lib/linux/link.c
 lib/linux/lstat.c
 lib/linux/mkdir.c
+lib/linux/mknod.c
 lib/linux/nanosleep.c
 lib/linux/pipe.c
+lib/linux/readlink.c
 lib/linux/rename.c
 lib/linux/setgid.c
 lib/linux/settimer.c
 lib/linux/setuid.c
 lib/linux/signal.c
 lib/linux/sigprogmask.c
+lib/linux/symlink.c
 "
 fi
 

build-aux/install.sh.in

@@ -77,13 +77,15 @@ else
     cp $_v ChangeLog ${DESTDIR}${docdir}
 fi
 
+if test -f module/mescc.go; then
+    __exclude_go=--exclude='*.go'
+    __exclude_scm=--exclude='*.scm'
+fi
 mkdir -p $DESTDIR$libdir
 mkdir -p $DESTDIR$pkgdatadir
-# rm -f $(find lib -type f -a -executable)
-# rm -f $(find scaffold -type f -a -executable)
 tar -cf- -C ${srcdir} include lib/$mes_cpu-mes | tar -${v}xf- -C $DESTDIR$prefix
 if test -z "$srcdest"; then
-    tar -cf- --exclude='*.go' module | tar -${v}xf- -C $DESTDIR$pkgdatadir
+    tar -cf- $__exclude_go module | tar -${v}xf- -C $DESTDIR$pkgdatadir
 else
     tar -cf- -C ${srcdest} module | tar -${v}xf- -C $DESTDIR$pkgdatadir
 fi
@@ -97,8 +99,8 @@ fi
 
 mkdir -p ${DESTDIR}${guile_site_dir}
 mkdir -p ${DESTDIR}${guile_site_ccache_dir}
-tar -cf- -C ${srcdest}module --exclude='*.go' . | tar -${v}xf- -C ${DESTDIR}${guile_site_dir}
-tar -cf- -C module --exclude='*.scm' . | tar -${v}xf- -C ${DESTDIR}${guile_site_ccache_dir}
+tar -cf- -C ${srcdest}module $__exclude_go . | tar -${v}xf- -C ${DESTDIR}${guile_site_dir}
+tar -cf- -C module $__exclude_scm . | tar -${v}xf- -C ${DESTDIR}${guile_site_ccache_dir}
 
 if test -f doc/mes.info; then
     mkdir -p ${DESTDIR}${infodir}

configure

@@ -632,11 +632,13 @@ See \"Porting GNU Mes\" in the manual, or try --with-courage\n" mes-system)
                     "build-aux/install.sh.in"
                     "build-aux/pre-inst-env.in"
                     "build-aux/uninstall.sh.in"
+                    "scripts/m2-merge.scm.in"
                     "scripts/mesar.in"
                     "scripts/mescc.scm.in"
                     "scripts/mescc.in"
                     ))
         (chmod "pre-inst-env" #o755)
+        (chmod "scripts/m2-merge.scm" #o755)
         (chmod "scripts/mesar" #o755)
         (chmod "scripts/mescc" #o755)
         (chmod "scripts/mescc.scm" #o755)

configure.sh

@@ -24,65 +24,35 @@ VERSION=0.20
 srcdir=${srcdir-$(dirname $0)}
 . ${srcdest}build-aux/trace.sh
 
-# parse --with-system-libc
-cmdline=$(echo " $@")
-p=${cmdline/ --with-system-libc/}
-if test "$p" != "$cmdline"; then
-    mes_libc=${mes_libc-system}
-else
-    mes_libc=mes
-fi
+# parse arguments
+while [ $# -gt 0 ]; do
+    case $1 in
+        (--with-courage)
+            courageous=true
+            ;;
+        (--with-system-libc)
+            mes_libc=system
+            ;;
+        (--build=*)
+            build=${1#--build=}
+            ;;
+        (--host=*)
+            host=${1#--host=}
+            ;;
+        (--prefix=*)
+            prefix=${1#--prefix=}
+            ;;
+        (--program-prefix=*)
+            program_prefix=${1#--program-prefix=}
+            ;;
+    esac
+    shift
+done
 
-# parse --with-courage
-cmdline=$(echo " $@")
-p=${cmdline/ --with-courage/}
-if test "$p" != "$cmdline"; then
-    courageous=true
-else
-    courageous=false
-fi
-
-# parse --prefix=PREFIX
-p=${cmdline/ --prefix=/ -prefix=}
-if test "$p" != "$cmdline"; then
-    p=${p##* -prefix=}
-    p=${p% *}
-    p=${p% -*}
-    prefix=${p-/usr/local}
-else
-    prefix=${prefix-/usr/local}
-fi
-
-# parse --build=BUILD
-p=${cmdline/ --build=/ -build=}
-if [ "$p" != "$cmdline" ]; then
-    p=${p##* -build=}
-    p=${p% *}
-    p=${p% -*}
-    build=${p-$build}
-else
-    build=$build
-fi
-
-# parse --host=HOST
-p=${cmdline/ --host=/ -host=}
-if [ "$p" != "$cmdline" ]; then
-    p=${p##* -host=}
-    p=${p% *}
-    p=${p% -*}
-    host=${p-$build}
-elif test -n "$build"; then
-    host=${host-$build}
-fi
-
-# parse --program-prefix=
-p=${cmdline/ --program-prefix=/ -program-prefix=}
-if test "$p" != "$cmdline"; then
-    p=${p##* -program-prefix=}
-    p=${p% *}
-    p=${p% -*}
-    program_prefix=$p
-fi
+prefix=${prefix-/usr/local}
+mes_libc=${mes_libc-mes}
+courageous=${courageous-false}
+host=${host-$build}
 
 AR=${AR-$(command -v ar)} || true
 BASH=${BASH-$(command -v bash)}

doc/announce/ANNOUNCE-0.20

@@ -7,7 +7,9 @@ We are pleased to announce the release of GNU Mes 0.20, representing
 147 commits over 38 weeks.
 
 Mes has now brought the Reduced Binary Seed bootstrap to Guix (bootstrap
-a GNU/Linux system without binary GNU toolchain or equivalent).
+a GNU/Linux system without binary GNU toolchain or equivalent).  It
+should land in Guix master any day now: a big thank you to everyone who
+helped, notably Ludovic and Mark.
 
 This release is a step towards the upcoming Scheme-only bootstrap and
 bringing Mes into NixOS and Debian.  This effort is now sponsored by
@@ -67,8 +69,8 @@ Packages are available in Guix master.
 
   Here are the MD5 and SHA1 checksums:
 
-  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  mes-0.20.tar.gz
-  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  mes-0.20.tar.gz
+  df839a83e4a2ad6c2a4accc5bf17b1a7  mes-0.20.tar.gz
+  38d4cb3fa28fa1f5fc57fea9e046d4d8052bbb8c  mes-0.20.tar.gz
 
   [*] Use a .sig file to verify that the corresponding file (without the
   .sig suffix) is intact.  First, be sure to download both the .sig file
@@ -83,6 +85,11 @@ Packages are available in Guix master.
 
   and rerun the 'gpg --verify' command.
 
+* Get informed, get involved
+
+  See https://bootstrappable.org
+  Join #bootstrappable on irc.freenode.net.
+
 * Changes in 0.20 since 0.19
  ** Core
  *** The build system has been simplified, again.
@@ -108,6 +115,9 @@ Packages are available in Guix master.
  *** string->number now support #x hex-prefix.
  *** ungetc now has a buffer per file handle.
 
+Greetings,
+janneke and Danny.
+
 [0] https://www.gnu.org/software/mes
 [1] http://joyofsource.com/reduced-binary-seed-bootstrap.html
 [2] https://www.gnu.org/software/guix
@@ -119,5 +129,5 @@ Packages are available in Guix master.
 [8] https://www.nongnu.org/nyacc
 [9] https://gitlab.com/janneke/tinycc
 [10] http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
-[11] https://github.com/oriansj/stage0
+[11] https://savannah.nongnu.org/projects/stage0
 [12] https://nlnet.nl/project/GNUMes

guix/git/mes.scm

@@ -131,7 +131,7 @@ extensive examples, including parsers for the Javascript and C99 languages.")
                 (uri (string-append
                       "https://ftp.gnu.org/pub/gnu/mes/mes-" version ".tar.gz"))
                 (sha256
-                 (base32 #!mes!# "06qkwkahcpzk5v4qydpvcvzm7lx8g8pflc48f9l7bpjz6hl5lk4s"))))
+                 (base32 #!mes!# "04pajp8v31na34ls4730ig5f6miiplhdvkmsb9ls1b8bbmw2vb4n"))))
       (build-system gnu-build-system)
       (supported-systems '("i686-linux" "x86_64-linux"))
       (propagated-inputs

include/ctype.h

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -35,6 +35,7 @@ int isalpha (int c);
 int isascii (int c);
 int iscntrl (int c);
 int isdigit (int c);
+int isgraph (int c);
 int islower (int c);
 int isnumber (int c, int base);
 int isprint (int c);

include/errno.h

@@ -38,14 +38,16 @@ int errno;
 #define ENOENT   2
 #define EINTR    4
 #define EIO      5
+#define ENXIO    6
 #define E2BIG    7
-#define	ENOEXEC  8
+#define ENOEXEC  8
 #define EBADF    9
 #define	ECHILD  10
 #define EAGAIN  11
 #define ENOMEM  12
 #define EACCES  13
 #define EEXIST  17
+#define EXDEV   18
 #define ENOTDIR 20
 #define EISDIR  21
 #define EINVAL  22

include/fcntl.h

@@ -48,6 +48,7 @@
 #define F_GETFL 3
 #define F_SETFL 4
 
+#define creat(file_name, mode) open (file_name, O_WRONLY | O_CREAT | O_TRUNC, mode)
 int dup (int old);
 int dup2 (int old, int new);
 int fcntl (int filedes, int command, ...);

include/linux/x86/syscall.h

@@ -83,4 +83,9 @@
 // make+POSIX
 #define SYS_sigprocmask 0x7e
 
+// tar
+#define SYS_symlink   0x53
+#define SYS_readlink  0x55
+#define SYS_mknod     0x0e
+
 #endif // __MES_LINUX_X86_SYSCALL_H

include/linux/x86_64/syscall.h

@@ -80,4 +80,9 @@
 // make+SYSTEM_LIBC
 #define SYS_rt_sigprocmask 0x0e
 
+// tar
+#define SYS_symlink   0x58
+#define SYS_readlink  0x59
+#define SYS_mknod     0x85
+
 #endif // __MES_LINUX_X86_64_SYSCALL_H

include/mes/builtins.h

@@ -1,416 +0,0 @@
-/* -*-comment-start: "//";comment-end:""-*-
- * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018,2019 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/>.
- */
-
-#ifndef __MES_BUILTINS_H
-#define __MES_BUILTINS_H
-
-// src/gc.mes
-SCM gc_check ();
-SCM gc ();
-// src/hash.mes
-SCM hashq (SCM x, SCM size);
-SCM hash (SCM x, SCM size);
-SCM hashq_get_handle (SCM table, SCM key, SCM dflt);
-SCM hashq_ref (SCM table, SCM key, SCM dflt);
-SCM hash_ref (SCM table, SCM key, SCM dflt);
-SCM hashq_set_x (SCM table, SCM key, SCM value);
-SCM hash_set_x (SCM table, SCM key, SCM value);
-SCM hash_table_printer (SCM table);
-SCM make_hash_table (SCM x);
-// src/lib.mes
-SCM procedure_name_ (SCM x);
-SCM display_ (SCM x);
-SCM display_error_ (SCM x);
-SCM display_port_ (SCM x, SCM p);
-SCM write_ (SCM x);
-SCM write_error_ (SCM x);
-SCM write_port_ (SCM x, SCM p);
-SCM exit_ (SCM x);
-SCM frame_printer (SCM frame);
-SCM make_stack (SCM stack);
-SCM stack_length (SCM stack);
-SCM stack_ref (SCM stack, SCM index);
-SCM xassq (SCM x, SCM a);
-SCM memq (SCM x, SCM a);
-SCM equal2_p (SCM a, SCM b);
-SCM last_pair (SCM x);
-SCM pair_p (SCM x);
-// src/math.mes
-SCM greater_p (SCM x);
-SCM less_p (SCM x);
-SCM is_p (SCM x);
-SCM minus (SCM x);
-SCM plus (SCM x);
-SCM divide (SCM x);
-SCM modulo (SCM a, SCM b);
-SCM multiply (SCM x);
-SCM logand (SCM x);
-SCM logior (SCM x);
-SCM lognot (SCM x);
-SCM logxor (SCM x);
-SCM ash (SCM n, SCM count);
-// src/mes.mes
-SCM make_cell_ (SCM type, SCM car, SCM cdr);
-SCM type_ (SCM x);
-SCM car_ (SCM x);
-SCM cdr_ (SCM x);
-SCM arity_ (SCM x);
-SCM cons (SCM x, SCM y);
-SCM car (SCM x);
-SCM cdr (SCM x);
-SCM list (SCM x);
-SCM null_p (SCM x);
-SCM eq_p (SCM x, SCM y);
-SCM values (SCM x);
-SCM acons (SCM key, SCM value, SCM alist);
-SCM length (SCM x);
-SCM error (SCM key, SCM x);
-SCM append2 (SCM x, SCM y);
-SCM append_reverse (SCM x, SCM y);
-SCM reverse_x_ (SCM x, SCM t);
-SCM pairlis (SCM x, SCM y, SCM a);
-SCM call (SCM fn, SCM x);
-SCM assq (SCM x, SCM a);
-SCM assoc (SCM x, SCM a);
-SCM set_car_x (SCM x, SCM e);
-SCM set_cdr_x (SCM x, SCM e);
-SCM set_env_x (SCM x, SCM e, SCM a);
-SCM macro_get_handle (SCM name);
-SCM add_formals (SCM formals, SCM x);
-SCM eval_apply ();
-SCM make_builtin_type ();
-SCM make_builtin (SCM builtin_type, SCM name, SCM arity, SCM function);
-SCM builtin_arity (SCM builtin);
-SCM builtin_p (SCM x);
-SCM builtin_printer (SCM builtin);
-// CONSTANT cell_nil 1
-#define cell_nil 1
-// CONSTANT cell_f 2
-#define cell_f 2
-// CONSTANT cell_t 3
-#define cell_t 3
-// CONSTANT cell_dot 4
-#define cell_dot 4
-// CONSTANT cell_arrow 5
-#define cell_arrow 5
-// CONSTANT cell_undefined 6
-#define cell_undefined 6
-// CONSTANT cell_unspecified 7
-#define cell_unspecified 7
-// CONSTANT cell_closure 8
-#define cell_closure 8
-// CONSTANT cell_circular 9
-#define cell_circular 9
-// CONSTANT cell_begin 10
-#define cell_begin 10
-// CONSTANT cell_call_with_current_continuation 11
-#define cell_call_with_current_continuation 11
-// CONSTANT cell_vm_apply 12
-#define cell_vm_apply 12
-// CONSTANT cell_vm_apply2 13
-#define cell_vm_apply2 13
-// CONSTANT cell_vm_begin 14
-#define cell_vm_begin 14
-// CONSTANT cell_vm_begin_eval 15
-#define cell_vm_begin_eval 15
-// CONSTANT cell_vm_begin_expand 16
-#define cell_vm_begin_expand 16
-// CONSTANT cell_vm_begin_expand_eval 17
-#define cell_vm_begin_expand_eval 17
-// CONSTANT cell_vm_begin_expand_macro 18
-#define cell_vm_begin_expand_macro 18
-// CONSTANT cell_vm_begin_expand_primitive_load 19
-#define cell_vm_begin_expand_primitive_load 19
-// CONSTANT cell_vm_begin_primitive_load 20
-#define cell_vm_begin_primitive_load 20
-// CONSTANT cell_vm_begin_read_input_file 21
-#define cell_vm_begin_read_input_file 21
-// CONSTANT cell_vm_call_with_current_continuation2 22
-#define cell_vm_call_with_current_continuation2 22
-// CONSTANT cell_vm_call_with_values2 23
-#define cell_vm_call_with_values2 23
-// CONSTANT cell_vm_eval 24
-#define cell_vm_eval 24
-// CONSTANT cell_vm_eval2 25
-#define cell_vm_eval2 25
-// CONSTANT cell_vm_eval_check_func 26
-#define cell_vm_eval_check_func 26
-// CONSTANT cell_vm_eval_define 27
-#define cell_vm_eval_define 27
-// CONSTANT cell_vm_eval_macro_expand_eval 28
-#define cell_vm_eval_macro_expand_eval 28
-// CONSTANT cell_vm_eval_macro_expand_expand 29
-#define cell_vm_eval_macro_expand_expand 29
-// CONSTANT cell_vm_eval_pmatch_car 30
-#define cell_vm_eval_pmatch_car 30
-// CONSTANT cell_vm_eval_pmatch_cdr 31
-#define cell_vm_eval_pmatch_cdr 31
-// CONSTANT cell_vm_eval_set_x 32
-#define cell_vm_eval_set_x 32
-// CONSTANT cell_vm_evlis 33
-#define cell_vm_evlis 33
-// CONSTANT cell_vm_evlis2 34
-#define cell_vm_evlis2 34
-// CONSTANT cell_vm_evlis3 35
-#define cell_vm_evlis3 35
-// CONSTANT cell_vm_if 36
-#define cell_vm_if 36
-// CONSTANT cell_vm_if_expr 37
-#define cell_vm_if_expr 37
-// CONSTANT cell_vm_macro_expand 38
-#define cell_vm_macro_expand 38
-// CONSTANT cell_vm_macro_expand_car 39
-#define cell_vm_macro_expand_car 39
-// CONSTANT cell_vm_macro_expand_cdr 40
-#define cell_vm_macro_expand_cdr 40
-// CONSTANT cell_vm_macro_expand_define 41
-#define cell_vm_macro_expand_define 41
-// CONSTANT cell_vm_macro_expand_define_macro 42
-#define cell_vm_macro_expand_define_macro 42
-// CONSTANT cell_vm_macro_expand_lambda 43
-#define cell_vm_macro_expand_lambda 43
-// CONSTANT cell_vm_macro_expand_set_x 44
-#define cell_vm_macro_expand_set_x 44
-// CONSTANT cell_vm_return 45
-#define cell_vm_return 45
-// CONSTANT cell_symbol_dot 46
-#define cell_symbol_dot 46
-// CONSTANT cell_symbol_lambda 47
-#define cell_symbol_lambda 47
-// CONSTANT cell_symbol_begin 48
-#define cell_symbol_begin 48
-// CONSTANT cell_symbol_if 49
-#define cell_symbol_if 49
-// CONSTANT cell_symbol_quote 50
-#define cell_symbol_quote 50
-// CONSTANT cell_symbol_define 51
-#define cell_symbol_define 51
-// CONSTANT cell_symbol_define_macro 52
-#define cell_symbol_define_macro 52
-// CONSTANT cell_symbol_quasiquote 53
-#define cell_symbol_quasiquote 53
-// CONSTANT cell_symbol_unquote 54
-#define cell_symbol_unquote 54
-// CONSTANT cell_symbol_unquote_splicing 55
-#define cell_symbol_unquote_splicing 55
-// CONSTANT cell_symbol_syntax 56
-#define cell_symbol_syntax 56
-// CONSTANT cell_symbol_quasisyntax 57
-#define cell_symbol_quasisyntax 57
-// CONSTANT cell_symbol_unsyntax 58
-#define cell_symbol_unsyntax 58
-// CONSTANT cell_symbol_unsyntax_splicing 59
-#define cell_symbol_unsyntax_splicing 59
-// CONSTANT cell_symbol_set_x 60
-#define cell_symbol_set_x 60
-// CONSTANT cell_symbol_sc_expand 61
-#define cell_symbol_sc_expand 61
-// CONSTANT cell_symbol_macro_expand 62
-#define cell_symbol_macro_expand 62
-// CONSTANT cell_symbol_portable_macro_expand 63
-#define cell_symbol_portable_macro_expand 63
-// CONSTANT cell_symbol_sc_expander_alist 64
-#define cell_symbol_sc_expander_alist 64
-// CONSTANT cell_symbol_call_with_values 65
-#define cell_symbol_call_with_values 65
-// CONSTANT cell_symbol_call_with_current_continuation 66
-#define cell_symbol_call_with_current_continuation 66
-// CONSTANT cell_symbol_boot_module 67
-#define cell_symbol_boot_module 67
-// CONSTANT cell_symbol_current_module 68
-#define cell_symbol_current_module 68
-// CONSTANT cell_symbol_primitive_load 69
-#define cell_symbol_primitive_load 69
-// CONSTANT cell_symbol_read_input_file 70
-#define cell_symbol_read_input_file 70
-// CONSTANT cell_symbol_write 71
-#define cell_symbol_write 71
-// CONSTANT cell_symbol_display 72
-#define cell_symbol_display 72
-// CONSTANT cell_symbol_car 73
-#define cell_symbol_car 73
-// CONSTANT cell_symbol_cdr 74
-#define cell_symbol_cdr 74
-// CONSTANT cell_symbol_not_a_number 75
-#define cell_symbol_not_a_number 75
-// CONSTANT cell_symbol_not_a_pair 76
-#define cell_symbol_not_a_pair 76
-// CONSTANT cell_symbol_system_error 77
-#define cell_symbol_system_error 77
-// CONSTANT cell_symbol_throw 78
-#define cell_symbol_throw 78
-// CONSTANT cell_symbol_unbound_variable 79
-#define cell_symbol_unbound_variable 79
-// CONSTANT cell_symbol_wrong_number_of_args 80
-#define cell_symbol_wrong_number_of_args 80
-// CONSTANT cell_symbol_wrong_type_arg 81
-#define cell_symbol_wrong_type_arg 81
-// CONSTANT cell_symbol_buckets 82
-#define cell_symbol_buckets 82
-// CONSTANT cell_symbol_builtin 83
-#define cell_symbol_builtin 83
-// CONSTANT cell_symbol_frame 84
-#define cell_symbol_frame 84
-// CONSTANT cell_symbol_hashq_table 85
-#define cell_symbol_hashq_table 85
-// CONSTANT cell_symbol_module 86
-#define cell_symbol_module 86
-// CONSTANT cell_symbol_procedure 87
-#define cell_symbol_procedure 87
-// CONSTANT cell_symbol_record_type 88
-#define cell_symbol_record_type 88
-// CONSTANT cell_symbol_size 89
-#define cell_symbol_size 89
-// CONSTANT cell_symbol_stack 90
-#define cell_symbol_stack 90
-// CONSTANT cell_symbol_argv 91
-#define cell_symbol_argv 91
-// CONSTANT cell_symbol_mes_prefix 92
-#define cell_symbol_mes_prefix 92
-// CONSTANT cell_symbol_mes_version 93
-#define cell_symbol_mes_version 93
-// CONSTANT cell_symbol_internal_time_units_per_second 94
-#define cell_symbol_internal_time_units_per_second 94
-// CONSTANT cell_symbol_compiler 95
-#define cell_symbol_compiler 95
-// CONSTANT cell_symbol_arch 96
-#define cell_symbol_arch 96
-// CONSTANT cell_symbol_pmatch_car 97
-#define cell_symbol_pmatch_car 97
-// CONSTANT cell_symbol_pmatch_cdr 98
-#define cell_symbol_pmatch_cdr 98
-// CONSTANT cell_type_bytes 99
-#define cell_type_bytes 99
-// CONSTANT cell_type_char 100
-#define cell_type_char 100
-// CONSTANT cell_type_closure 101
-#define cell_type_closure 101
-// CONSTANT cell_type_continuation 102
-#define cell_type_continuation 102
-// CONSTANT cell_type_function 103
-#define cell_type_function 103
-// CONSTANT cell_type_keyword 104
-#define cell_type_keyword 104
-// CONSTANT cell_type_macro 105
-#define cell_type_macro 105
-// CONSTANT cell_type_number 106
-#define cell_type_number 106
-// CONSTANT cell_type_pair 107
-#define cell_type_pair 107
-// CONSTANT cell_type_port 108
-#define cell_type_port 108
-// CONSTANT cell_type_ref 109
-#define cell_type_ref 109
-// CONSTANT cell_type_special 110
-#define cell_type_special 110
-// CONSTANT cell_type_string 111
-#define cell_type_string 111
-// CONSTANT cell_type_struct 112
-#define cell_type_struct 112
-// CONSTANT cell_type_symbol 113
-#define cell_type_symbol 113
-// CONSTANT cell_type_values 114
-#define cell_type_values 114
-// CONSTANT cell_type_variable 115
-#define cell_type_variable 115
-// CONSTANT cell_type_vector 116
-#define cell_type_vector 116
-// CONSTANT cell_type_broken_heart 117
-#define cell_type_broken_heart 117
-// CONSTANT cell_symbol_test 118
-#define cell_symbol_test 118
-// src/module.mes
-SCM make_module_type ();
-SCM module_printer (SCM module);
-SCM module_variable (SCM module, SCM name);
-SCM module_ref (SCM module, SCM name);
-SCM module_define_x (SCM module, SCM name, SCM value);
-// src/posix.mes
-SCM peek_byte ();
-SCM read_byte ();
-SCM unread_byte (SCM i);
-SCM peek_char ();
-SCM read_char (SCM port);
-SCM unread_char (SCM i);
-SCM write_char (SCM i);
-SCM write_byte (SCM x);
-SCM getenv_ (SCM s);
-SCM setenv_ (SCM s, SCM v);
-SCM access_p (SCM file_name, SCM mode);
-SCM current_input_port ();
-SCM open_input_file (SCM file_name);
-SCM open_input_string (SCM string);
-SCM set_current_input_port (SCM port);
-SCM current_output_port ();
-SCM current_error_port ();
-SCM open_output_file (SCM x);
-SCM set_current_output_port (SCM port);
-SCM set_current_error_port (SCM port);
-SCM force_output (SCM p);
-SCM chmod_ (SCM file_name, SCM mode);
-SCM isatty_p (SCM port);
-SCM primitive_fork ();
-SCM execl_ (SCM file_name, SCM args);
-SCM waitpid_ (SCM pid, SCM options);
-SCM current_time ();
-SCM gettimeofday_ ();
-SCM get_internal_run_time ();
-SCM getcwd_ ();
-SCM dup_ (SCM port);
-SCM dup2_ (SCM old, SCM new);
-SCM delete_file (SCM file_name);
-// src/reader.mes
-SCM read_input_file_env_ (SCM e, SCM a);
-SCM read_input_file_env (SCM a);
-SCM read_env (SCM a);
-SCM reader_read_sexp (SCM c, SCM s, SCM a);
-SCM reader_read_character ();
-SCM reader_read_binary ();
-SCM reader_read_octal ();
-SCM reader_read_hex ();
-SCM reader_read_string ();
-// src/strings.mes
-SCM string_equal_p (SCM a, SCM b);
-SCM symbol_to_string (SCM symbol);
-SCM symbol_to_keyword (SCM symbol);
-SCM keyword_to_string (SCM keyword);
-SCM string_to_symbol (SCM string);
-SCM make_symbol (SCM string);
-SCM string_to_list (SCM string);
-SCM list_to_string (SCM list);
-SCM read_string (SCM port);
-SCM string_append (SCM x);
-SCM string_length (SCM string);
-SCM string_ref (SCM str, SCM k);
-// src/struct.mes
-SCM make_struct (SCM type, SCM fields, SCM printer);
-SCM struct_length (SCM x);
-SCM struct_ref (SCM x, SCM i);
-SCM struct_set_x (SCM x, SCM i, SCM e);
-// src/vector.mes
-SCM make_vector_ (SCM n);
-SCM vector_length (SCM x);
-SCM vector_ref (SCM x, SCM i);
-SCM vector_entry (SCM x);
-SCM vector_set_x (SCM x, SCM i, SCM e);
-SCM list_to_vector (SCM x);
-SCM vector_to_list (SCM v);
-
-#endif //__MES_BUILTINS_H

include/mes/constants.h

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
  * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,257 +22,6 @@
 #ifndef __MES_CONSTANTS_H
 #define __MES_CONSTANTS_H
 
-/* Symbols */
-
-// CONSTANT cell_nil 1
-#define cell_nil 1
-// CONSTANT cell_f 2
-#define cell_f 2
-// CONSTANT cell_t 3
-#define cell_t 3
-// CONSTANT cell_dot 4
-#define cell_dot 4
-// CONSTANT cell_arrow 5
-#define cell_arrow 5
-// CONSTANT cell_undefined 6
-#define cell_undefined 6
-// CONSTANT cell_unspecified 7
-#define cell_unspecified 7
-// CONSTANT cell_closure 8
-#define cell_closure 8
-// CONSTANT cell_circular 9
-#define cell_circular 9
-// CONSTANT cell_begin 10
-#define cell_begin 10
-// CONSTANT cell_call_with_current_continuation 11
-#define cell_call_with_current_continuation 11
-
-// CONSTANT cell_vm_apply 12
-#define cell_vm_apply 12
-// CONSTANT cell_vm_apply2 13
-#define cell_vm_apply2 13
-// CONSTANT cell_vm_begin 14
-#define cell_vm_begin 14
-// CONSTANT cell_vm_begin_eval 15
-#define cell_vm_begin_eval 15
-// CONSTANT cell_vm_begin_expand 16
-#define cell_vm_begin_expand 16
-// CONSTANT cell_vm_begin_expand_eval 17
-#define cell_vm_begin_expand_eval 17
-// CONSTANT cell_vm_begin_expand_macro 18
-#define cell_vm_begin_expand_macro 18
-// CONSTANT cell_vm_begin_expand_primitive_load 19
-#define cell_vm_begin_expand_primitive_load 19
-// CONSTANT cell_vm_begin_primitive_load 20
-#define cell_vm_begin_primitive_load 20
-// CONSTANT cell_vm_begin_read_input_file 21
-#define cell_vm_begin_read_input_file 21
-// CONSTANT cell_vm_call_with_current_continuation2 22
-#define cell_vm_call_with_current_continuation2 22
-// CONSTANT cell_vm_call_with_values2 23
-#define cell_vm_call_with_values2 23
-// CONSTANT cell_vm_eval 24
-#define cell_vm_eval 24
-// CONSTANT cell_vm_eval2 25
-#define cell_vm_eval2 25
-// CONSTANT cell_vm_eval_check_func 26
-#define cell_vm_eval_check_func 26
-// CONSTANT cell_vm_eval_define 27
-#define cell_vm_eval_define 27
-// CONSTANT cell_vm_eval_macro_expand_eval 28
-#define cell_vm_eval_macro_expand_eval 28
-// CONSTANT cell_vm_eval_macro_expand_expand 29
-#define cell_vm_eval_macro_expand_expand 29
-// CONSTANT cell_vm_eval_pmatch_car 30
-#define cell_vm_eval_pmatch_car 30
-// CONSTANT cell_vm_eval_pmatch_cdr 31
-#define cell_vm_eval_pmatch_cdr 31
-// CONSTANT cell_vm_eval_set_x 32
-#define cell_vm_eval_set_x 32
-// CONSTANT cell_vm_evlis 33
-#define cell_vm_evlis 33
-// CONSTANT cell_vm_evlis2 34
-#define cell_vm_evlis2 34
-// CONSTANT cell_vm_evlis3 35
-#define cell_vm_evlis3 35
-// CONSTANT cell_vm_if 36
-#define cell_vm_if 36
-// CONSTANT cell_vm_if_expr 37
-#define cell_vm_if_expr 37
-// CONSTANT cell_vm_macro_expand 38
-#define cell_vm_macro_expand 38
-// CONSTANT cell_vm_macro_expand_car 39
-#define cell_vm_macro_expand_car 39
-// CONSTANT cell_vm_macro_expand_cdr 40
-#define cell_vm_macro_expand_cdr 40
-// CONSTANT cell_vm_macro_expand_define 41
-#define cell_vm_macro_expand_define 41
-// CONSTANT cell_vm_macro_expand_define_macro 42
-#define cell_vm_macro_expand_define_macro 42
-// CONSTANT cell_vm_macro_expand_lambda 43
-#define cell_vm_macro_expand_lambda 43
-// CONSTANT cell_vm_macro_expand_set_x 44
-#define cell_vm_macro_expand_set_x 44
-// CONSTANT cell_vm_return 45
-#define cell_vm_return 45
-
-// CONSTANT cell_symbol_dot 46
-#define cell_symbol_dot 46
-// CONSTANT cell_symbol_lambda 47
-#define cell_symbol_lambda 47
-// CONSTANT cell_symbol_begin 48
-#define cell_symbol_begin 48
-// CONSTANT cell_symbol_if 49
-#define cell_symbol_if 49
-// CONSTANT cell_symbol_quote 50
-#define cell_symbol_quote 50
-// CONSTANT cell_symbol_define 51
-#define cell_symbol_define 51
-// CONSTANT cell_symbol_define_macro 52
-#define cell_symbol_define_macro 52
-
-// CONSTANT cell_symbol_quasiquote 53
-#define cell_symbol_quasiquote 53
-// CONSTANT cell_symbol_unquote 54
-#define cell_symbol_unquote 54
-// CONSTANT cell_symbol_unquote_splicing 55
-#define cell_symbol_unquote_splicing 55
-// CONSTANT cell_symbol_syntax 56
-#define cell_symbol_syntax 56
-// CONSTANT cell_symbol_quasisyntax 57
-#define cell_symbol_quasisyntax 57
-// CONSTANT cell_symbol_unsyntax 58
-#define cell_symbol_unsyntax 58
-// CONSTANT cell_symbol_unsyntax_splicing 59
-#define cell_symbol_unsyntax_splicing 59
-
-// CONSTANT cell_symbol_set_x 60
-#define cell_symbol_set_x 60
-
-// CONSTANT cell_symbol_sc_expand 61
-#define cell_symbol_sc_expand 61
-// CONSTANT cell_symbol_macro_expand 62
-#define cell_symbol_macro_expand 62
-// CONSTANT cell_symbol_portable_macro_expand 63
-#define cell_symbol_portable_macro_expand 63
-// CONSTANT cell_symbol_sc_expander_alist 64
-#define cell_symbol_sc_expander_alist 64
-
-// CONSTANT cell_symbol_call_with_values 65
-#define cell_symbol_call_with_values 65
-// CONSTANT cell_symbol_call_with_current_continuation 66
-#define cell_symbol_call_with_current_continuation 66
-// CONSTANT cell_symbol_boot_module 67
-#define cell_symbol_boot_module 67
-// CONSTANT cell_symbol_current_module 68
-#define cell_symbol_current_module 68
-// CONSTANT cell_symbol_primitive_load 69
-#define cell_symbol_primitive_load 69
-// CONSTANT cell_symbol_read_input_file 70
-#define cell_symbol_read_input_file 70
-// CONSTANT cell_symbol_write 71
-#define cell_symbol_write 71
-// CONSTANT cell_symbol_display 72
-#define cell_symbol_display 72
-
-// CONSTANT cell_symbol_car 73
-#define cell_symbol_car 73
-// CONSTANT cell_symbol_cdr 74
-#define cell_symbol_cdr 74
-// CONSTANT cell_symbol_not_a_number 75
-#define cell_symbol_not_a_number 75
-// CONSTANT cell_symbol_not_a_pair 76
-#define cell_symbol_not_a_pair 76
-// CONSTANT cell_symbol_system_error 77
-#define cell_symbol_system_error 77
-// CONSTANT cell_symbol_throw 78
-#define cell_symbol_throw 78
-// CONSTANT cell_symbol_unbound_variable 79
-#define cell_symbol_unbound_variable 79
-// CONSTANT cell_symbol_wrong_number_of_args 80
-#define cell_symbol_wrong_number_of_args 80
-// CONSTANT cell_symbol_wrong_type_arg 81
-#define cell_symbol_wrong_type_arg 81
-
-// CONSTANT cell_symbol_buckets 82
-#define cell_symbol_buckets 82
-// CONSTANT cell_symbol_builtin 83
-#define cell_symbol_builtin 83
-// CONSTANT cell_symbol_frame 84
-#define cell_symbol_frame 84
-// CONSTANT cell_symbol_hashq_table 85
-#define cell_symbol_hashq_table 85
-// CONSTANT cell_symbol_module 86
-#define cell_symbol_module 86
-// CONSTANT cell_symbol_procedure 87
-#define cell_symbol_procedure 87
-// CONSTANT cell_symbol_record_type 88
-#define cell_symbol_record_type 88
-// CONSTANT cell_symbol_size 89
-#define cell_symbol_size 89
-// CONSTANT cell_symbol_stack 90
-#define cell_symbol_stack 90
-
-// CONSTANT cell_symbol_argv 91
-#define cell_symbol_argv 91
-// CONSTANT cell_symbol_mes_datadir 92
-#define cell_symbol_mes_datadir 92
-// CONSTANT cell_symbol_mes_version 93
-#define cell_symbol_mes_version 93
-
-// CONSTANT cell_symbol_internal_time_units_per_second 94
-#define cell_symbol_internal_time_units_per_second 94
-// CONSTANT cell_symbol_compiler 95
-#define cell_symbol_compiler 95
-// CONSTANT cell_symbol_arch 96
-#define cell_symbol_arch 96
-// CONSTANT cell_symbol_pmatch_car 97
-#define cell_symbol_pmatch_car 97
-// CONSTANT cell_symbol_pmatch_cdr 98
-#define cell_symbol_pmatch_cdr 98
-
-// CONSTANT cell_type_bytes 99
-#define cell_type_bytes 99
-// CONSTANT cell_type_char 100
-#define cell_type_char 100
-// CONSTANT cell_type_closure 101
-#define cell_type_closure 101
-// CONSTANT cell_type_continuation 102
-#define cell_type_continuation 102
-// CONSTANT cell_type_function 103
-#define cell_type_function 103
-// CONSTANT cell_type_keyword 104
-#define cell_type_keyword 104
-// CONSTANT cell_type_macro 105
-#define cell_type_macro 105
-// CONSTANT cell_type_number 106
-#define cell_type_number 106
-// CONSTANT cell_type_pair 107
-#define cell_type_pair 107
-// CONSTANT cell_type_port 108
-#define cell_type_port 108
-// CONSTANT cell_type_ref 109
-#define cell_type_ref 109
-// CONSTANT cell_type_special 110
-#define cell_type_special 110
-// CONSTANT cell_type_string 111
-#define cell_type_string 111
-// CONSTANT cell_type_struct 112
-#define cell_type_struct 112
-// CONSTANT cell_type_symbol 113
-#define cell_type_symbol 113
-// CONSTANT cell_type_values 114
-#define cell_type_values 114
-// CONSTANT cell_type_variable 115
-#define cell_type_variable 115
-// CONSTANT cell_type_vector 116
-#define cell_type_vector 116
-// CONSTANT cell_type_broken_heart 117
-#define cell_type_broken_heart 117
-
-// CONSTANT cell_test 118
-#define cell_test 118
-
 /* Cell types */
 
 // CONSTANT TBYTES         0
@@ -311,14 +61,4 @@
 // CONSTANT TBROKEN_HEART 17
 #define TBROKEN_HEART     17
 
-/* Struct types */
-
-// CONSTANT STRUCT_TYPE 0
-#define STRUCT_TYPE 0
-// CONSTANT STRUCT_PRINTER 1
-#define STRUCT_PRINTER 1
-
-#define FRAME_SIZE 5
-#define FRAME_PROCEDURE 4
-
 #endif //__MES_CONSTANTS_H

include/mes/gcc.h

@@ -0,0 +1,29 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians
+ *
+ * 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 <stdlib.h>
+#include <stdio.h>
+typedef long SCM;
+typedef struct scm *(FUNCTION) ();
+typedef struct scm *(FUNCTION0) ();
+typedef struct scm *(FUNCTION1) (struct scm *);
+typedef struct scm *(FUNCTION2) (struct scm *, struct scm *);
+typedef struct scm *(FUNCTION3) (struct scm *, struct scm *, struct scm *);

include/mes/lib.h

@@ -28,7 +28,9 @@ void __ungetc_init ();
 void __ungetc_clear (int filedes);
 void __ungetc_set (int filedes, int c);
 int __ungetc_p (int filedes);
+double abtod (char const **p, int base);
 long abtol (char const **p, int base);
+char *dtoab (double number, int base, int signed_p);
 char *itoa (int number);
 char *ltoa (long number);
 char *ltoab (long x, int base);

include/mes/m2.h

@@ -0,0 +1,167 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018,2019 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/>.
+ */
+
+#ifndef __MES_M2_H
+#define __MES_M2_H
+
+#define __FILEDES_MAX 512
+
+SCM length__ (struct scm *x);
+char *char_lookup (int c, int type);
+char *env_lookup (char *token, char **envp);
+char *itoa (int number);
+char *ltoa (SCM number);
+char *ltoab (SCM x, int base);
+char *ntoab (SCM number, int base, int signed_p);
+char *search_path (char *file_name);
+int __mes_debug ();
+int __ungetc_p (int filedes);
+int _fdungetc_p (int fd);
+int _open2 (char *file_name, int flags);
+int _open3 (char *file_name, int flags, int mask);
+int eputc (int c);
+int fdgetc (int fd);
+int fdputc (int c, int fd);
+int fdputs (char *s, int fd);
+int fdungetc (int c, int fd);
+int get_env_value (char *c, int alt);
+int in_set (int c, char *s);
+int isdigit (int c);
+int isspace (int c);
+int isxdigit (int c);
+int match (char *a, char *b);
+int mes_open (char *file_name, int flags, int mask);
+int numerate_string (char *a);
+int oputc (int c);
+int peekchar ();
+int readchar ();
+int string_len (char *a);
+int unreadchar ();
+struct scm *acons (struct scm *key, struct scm *value, struct scm *alist);
+struct scm *append2 (struct scm *x, struct scm *y);
+struct scm *apply (struct scm *f, struct scm *x);
+struct scm *apply_builtin (struct scm *fn, struct scm *x);
+struct scm *assert_defined (struct scm *x, struct scm *e);
+struct scm *assoc (struct scm *x, struct scm *a);
+struct scm *assq (struct scm *x, struct scm *a);
+struct scm *builtin_arity (struct scm *builtin);
+struct scm *builtin_p (struct scm *x);
+struct scm *call_lambda (struct scm *e, struct scm *x);
+struct scm *cdr (struct scm *x);
+struct scm *check_apply (struct scm *f, struct scm *e);
+struct scm *check_formals (struct scm *f, struct scm *formals, struct scm *args);
+struct scm *cons (struct scm *x, struct scm *y);
+struct scm *cstring_to_symbol (char *s);
+struct scm *current_input_port ();
+struct scm *display_ (struct scm *x);
+struct scm *display_error_ (struct scm *x);
+struct scm *eq_p (struct scm *x, struct scm *y);
+struct scm *equal2_p (struct scm *a, struct scm *b);
+struct scm *error (struct scm *key, struct scm *x);
+struct scm *eval_apply ();
+struct scm *expand_variable (struct scm *x, struct scm *formals);
+struct scm *fdisplay_ (struct scm *, int, int);
+struct scm *gc ();
+struct scm *gc_check ();
+struct scm *gc_pop_frame ();
+struct scm *get_macro (struct scm *name);
+struct scm *hash_ref (struct scm *table, struct scm *key, struct scm *dflt);
+struct scm *hash_set_x (struct scm *table, struct scm *key, struct scm *value);
+struct scm *hashq_get_handle (struct scm *table, struct scm *key, struct scm *dflt);
+struct scm *hashq_set_x (struct scm *table, struct scm *key, struct scm *value);
+struct scm *init_time (struct scm *a);
+struct scm *list_to_vector (struct scm *x);
+struct scm *macro_get_handle (struct scm *name);
+struct scm *macro_set_x (struct scm *name, struct scm *value);
+struct scm *make_bytes (char *s, SCM length);
+struct scm *make_char (SCM c);
+struct scm *make_closure_ (struct scm *args, struct scm *body, struct scm *a);
+struct scm *make_frame_type ();
+struct scm *make_hash_table_ (SCM size);
+struct scm *make_hashq_type ();
+struct scm *make_keyword (struct scm *a, struct scm *b);
+struct scm *make_module_type ();
+struct scm *make_number (SCM n);
+struct scm *make_port (SCM n, struct scm *s);
+struct scm *make_stack_type ();
+struct scm *make_string (char *s, int length);
+struct scm *make_string_ (char *s);
+struct scm *make_struct (struct scm *type, struct scm *fields, struct scm *printer);
+struct scm *make_tcontinuation (SCM a, SCM b);
+struct scm *make_tmacro (struct scm *a, struct scm *b);
+struct scm *make_tpair (struct scm *a, struct scm *b);
+struct scm *make_tref (struct scm *x);
+struct scm *make_tstring1 (SCM n);
+struct scm *make_tstring2 (struct scm *a, struct scm *b);
+struct scm *make_tsymbol (struct scm *a, struct scm *b);
+struct scm *make_variable_ (struct scm *var);
+struct scm *make_vector__ (SCM k);
+struct scm *mes_builtins (struct scm *a);
+struct scm *mes_g_stack (struct scm *a);
+struct scm *mes_symbols ();
+struct scm *module_define_x (struct scm *module, struct scm *name, struct scm *value);
+struct scm *module_printer (struct scm *module);
+struct scm *module_ref (struct scm *module, struct scm *name);
+struct scm *module_variable (struct scm *module, struct scm *name);
+struct scm *open_input_file (struct scm *file_name);
+struct scm *pairlis (struct scm *x, struct scm *y, struct scm *a);
+struct scm *push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c);
+struct scm *read_env (struct scm *a);
+struct scm *read_input_file_env ();
+struct scm *reverse_x_ (struct scm *x, struct scm *t);
+struct scm *set_cdr_x (struct scm *x, struct scm *e);
+struct scm *set_current_input_port (struct scm *port);
+struct scm *set_env_x (struct scm *x, struct scm *e, struct scm *a);
+struct scm *string_equal_p (struct scm *a, struct scm *b);
+struct scm *struct_ref_ (struct scm *x, SCM i);
+struct scm *symbol_to_keyword (struct scm *symbol);
+struct scm *vector_entry (struct scm *x);
+struct scm *vector_equal_p (struct scm *a, struct scm *b);
+struct scm *vector_length (struct scm *x);
+struct scm *vector_ref_ (struct scm *table, long i);
+struct scm *vector_ref_ (struct scm *x, SCM i);
+struct scm *write_error_ (struct scm *x);
+void __ungetc_clear (int filedes);
+void __ungetc_init ();
+void __ungetc_set (int filedes, int c);
+void assert_max_string (int i, char *msg, char *string);
+void block_copy (void *source, void *destination, int num);
+void gc_init_cells ();
+void gc_push_frame ();
+void initialize_constants ();
+void initialize_memory ();
+void raw_print (char *s, int fd);
+void require (int bool, char *error);
+void vector_set_x_ (struct scm *x, SCM i, struct scm *e);
+
+#if __M2_PLANET__
+char *MES_VERSION = "git";
+char *MES_PKGDATADIR = "/usr/local/share/mes";
+
+SCM strlen (char *s);
+SCM write (int filedes, void *buffer, SCM size);
+int atoi (char *s);
+int eputs (char *s);
+int fdputs (char s, int fd);
+int open (char *file_name, int flags, int mask);
+int oputs (char s);
+#endif
+
+#endif //__MES_M2_H

include/mes/mes.h

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians
  *
  * This file is part of GNU Mes.
  *
@@ -18,89 +19,213 @@
  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
-#ifndef __MES_MES_H
-#define __MES_MES_H
+#include "mes/constants.h"
+#include "mes/gcc.h"
+#include "mes/m2.h"
+#include <assert.h>
+#include <stdlib.h>
+#include <string.h>
 
-#include <sys/types.h>
+// CONSTANT STDIN 0
+#define STDIN 0
+// CONSTANT STDOUT 1
+#define STDOUT 1
+// CONSTANT STDERR 2
+#define STDERR 2
 
-typedef long SCM;
+// CONSTANT FALSE 0
+#define FALSE 0
+// CONSTANT TRUE 1
+#define TRUE 1
+
+// CONSTANT RLIMIT_NOFILE 1024
+#define RLIMIT_NOFILE 1024
+// CONSTANT FRAME_PROCEDURE 4
+#define FRAME_PROCEDURE 4
 
 struct scm
 {
-  long type;
-  SCM car;
-  SCM cdr;
+  SCM type;
+  union
+  {
+    struct scm *car;
+    SCM rac;
+    SCM length;
+    struct scm *macro;
+    SCM port;
+  };
+  union
+  {
+    struct scm *cdr;
+    char *cbytes;
+    struct scm *closure;
+    struct scm *continuation;
+    SCM value;
+    struct scm *vector;
+    char *string;
+    struct scm *struc;
+  };
 };
 
-// mes
-extern int g_debug;
-extern char *g_buf;
-extern SCM g_continuations;
-extern SCM g_symbols;
-extern SCM g_symbol_max;
+// CONSTANT CELL_SIZE sizeof(struct scm)
+#define CELL_SIZE 1
 
-// a/env
-extern SCM r0;
-// param 1
-extern SCM r1;
-// save 2
-extern SCM r2;
-// continuation
-extern SCM r3;
-// current-module
-extern SCM m0;
-// macro
-extern SCM g_macros;
-extern SCM g_ports;
+struct scm *g_cells;
 
-// gc
-extern long ARENA_SIZE;
-extern long MAX_ARENA_SIZE;
-extern long STACK_SIZE;
-extern long JAM_SIZE;
-extern long GC_SAFETY;
-extern long MAX_STRING;
-extern char *g_arena;
-extern long g_free;
-extern SCM g_stack;
-extern SCM *g_stack_array;
-extern struct scm *g_cells;
-extern struct scm *g_news;
+char **environ;
+int __stdin;
+int __stdout;
+int __stderr;
+char g_datadir[1024];
+SCM g_continuations;
+struct scm *g_symbols;
+SCM g_stack;
+struct scm **g_stack_array;
+int MAX_STRING;
+int STACK_SIZE;
+char *g_buf;
+SCM g_free;
+int g_debug;
+SCM g_symbol_max;
 
-SCM alloc (long n);
-SCM apply (SCM f, SCM x, SCM a);
-SCM apply_builtin (SCM fn, SCM x);
-SCM cstring_to_list (char const *s);
-SCM cstring_to_symbol (char const *s);
-SCM display_ (SCM x);
-SCM fdisplay_ (SCM, int, int);
-SCM gc_init ();
-SCM gc_peek_frame ();
-SCM gc_pop_frame ();
-SCM gc_push_frame ();
-SCM init_time (SCM a);
-SCM make_bytes (char const *s, size_t length);
-SCM make_cell__ (long type, SCM car, SCM cdr);
-SCM make_hash_table_ (long size);
-SCM make_hashq_type ();
-SCM make_initial_module (SCM a);
-SCM make_string (char const *s, size_t length);
-SCM make_vector__ (long k);
-SCM read_input_file_env (SCM);
-SCM string_equal_p (SCM a, SCM b);
-SCM struct_ref_ (SCM x, long i);
-SCM struct_set_x_ (SCM x, long i, SCM e);
-SCM vector_ref_ (SCM x, long i);
-SCM vector_set_x_ (SCM x, long i, SCM e);
-int peekchar ();
-int readchar ();
-int unreadchar ();
-long length__ (SCM x);
-size_t bytes_cells (size_t length);
-void assert_max_string (size_t i, char const *msg, char *string);
+/* Mes core locals */
+struct scm *R0;
+/* param 1 */
+struct scm *R1;
+/* save 2 */
+struct scm *R2;
+/* continuation */
+struct scm *R3;
+/* current-module */
+struct scm *M0;
+/* macro */
+struct scm *g_macros;
+struct scm *G_MACROS;
+struct scm *g_ports;
+struct scm *G_PORTS;
 
-#include "mes/builtins.h"
-#include "mes/constants.h"
-#include "mes/macros.h"
+/* Try to fix native */
+int messy_display;
+SCM answer;
+char **global_envp;
+int STACK_SIZE;
 
-#endif //__MES_MES_H
+struct scm *cell_nil;
+struct scm *cell_f;
+struct scm *cell_t;
+struct scm *cell_dot;
+struct scm *cell_arrow;
+struct scm *cell_undefined;
+struct scm *cell_unspecified;
+struct scm *cell_closure;
+struct scm *cell_circular;
+struct scm *cell_begin;
+struct scm *cell_call_with_current_continuation;
+struct scm *cell_vm_apply;
+struct scm *cell_vm_apply2;
+struct scm *cell_vm_begin;
+struct scm *cell_vm_begin_eval;
+struct scm *cell_vm_begin_expand;
+struct scm *cell_vm_begin_expand_eval;
+struct scm *cell_vm_begin_expand_macro;
+struct scm *cell_vm_begin_expand_primitive_load;
+struct scm *cell_vm_begin_primitive_load;
+struct scm *cell_vm_begin_read_input_file;
+struct scm *cell_vm_call_with_current_continuation2;
+struct scm *cell_vm_call_with_values2;
+struct scm *cell_vm_eval;
+struct scm *cell_vm_eval2;
+struct scm *cell_vm_eval_check_func;
+struct scm *cell_vm_eval_define;
+struct scm *cell_vm_eval_macro_expand_eval;
+struct scm *cell_vm_eval_macro_expand_expand;
+struct scm *cell_vm_eval_pmatch_car;
+struct scm *cell_vm_eval_pmatch_cdr;
+struct scm *cell_vm_eval_set_x;
+struct scm *cell_vm_evlis;
+struct scm *cell_vm_evlis2;
+struct scm *cell_vm_evlis3;
+struct scm *cell_vm_if;
+struct scm *cell_vm_if_expr;
+struct scm *cell_vm_macro_expand;
+struct scm *cell_vm_macro_expand_car;
+struct scm *cell_vm_macro_expand_cdr;
+struct scm *cell_vm_macro_expand_define;
+struct scm *cell_vm_macro_expand_define_macro;
+struct scm *cell_vm_macro_expand_lambda;
+struct scm *cell_vm_macro_expand_set_x;
+struct scm *cell_vm_return;
+struct scm *cell_symbol_dot;
+struct scm *cell_symbol_lambda;
+struct scm *cell_symbol_begin;
+struct scm *cell_symbol_if;
+struct scm *cell_symbol_quote;
+struct scm *cell_symbol_define;
+struct scm *cell_symbol_define_macro;
+struct scm *cell_symbol_quasiquote;
+struct scm *cell_symbol_unquote;
+struct scm *cell_symbol_unquote_splicing;
+struct scm *cell_symbol_syntax;
+struct scm *cell_symbol_quasisyntax;
+struct scm *cell_symbol_unsyntax;
+struct scm *cell_symbol_unsyntax_splicing;
+struct scm *cell_symbol_set_x;
+struct scm *cell_symbol_sc_expand;
+struct scm *cell_symbol_macro_expand;
+struct scm *cell_symbol_portable_macro_expand;
+struct scm *cell_symbol_sc_expander_alist;
+struct scm *cell_symbol_call_with_values;
+struct scm *cell_symbol_call_with_current_continuation;
+struct scm *cell_symbol_boot_module;
+struct scm *cell_symbol_current_module;
+struct scm *cell_symbol_primitive_load;
+struct scm *cell_symbol_read_input_file;
+struct scm *cell_symbol_write;
+struct scm *cell_symbol_display;
+struct scm *cell_symbol_car;
+struct scm *cell_symbol_cdr;
+struct scm *cell_symbol_not_a_number;
+struct scm *cell_symbol_not_a_pair;
+struct scm *cell_symbol_system_error;
+struct scm *cell_symbol_throw;
+struct scm *cell_symbol_unbound_variable;
+struct scm *cell_symbol_wrong_number_of_args;
+struct scm *cell_symbol_wrong_type_arg;
+struct scm *cell_symbol_buckets;
+struct scm *cell_symbol_builtin;
+struct scm *cell_symbol_frame;
+struct scm *cell_symbol_hashq_table;
+struct scm *cell_symbol_module;
+struct scm *cell_symbol_procedure;
+struct scm *cell_symbol_record_type;
+struct scm *cell_symbol_size;
+struct scm *cell_symbol_stack;
+struct scm *cell_symbol_argv;
+struct scm *cell_symbol_mes_datadir;
+struct scm *cell_symbol_mes_version;
+struct scm *cell_symbol_internal_time_units_per_second;
+struct scm *cell_symbol_compiler;
+struct scm *cell_symbol_arch;
+struct scm *cell_symbol_pmatch_car;
+struct scm *cell_symbol_pmatch_cdr;
+struct scm *cell_type_bytes;
+struct scm *cell_type_char;
+struct scm *cell_type_closure;
+struct scm *cell_type_continuation;
+struct scm *cell_type_function;
+struct scm *cell_type_keyword;
+struct scm *cell_type_macro;
+struct scm *cell_type_number;
+struct scm *cell_type_pair;
+struct scm *cell_type_port;
+struct scm *cell_type_ref;
+struct scm *cell_type_special;
+struct scm *cell_type_string;
+struct scm *cell_type_struct;
+struct scm *cell_type_symbol;
+struct scm *cell_type_values;
+struct scm *cell_type_variable;
+struct scm *cell_type_vector;
+struct scm *cell_type_broken_heart;
+struct scm *cell_symbol_test;
+struct scm *cell_test;

include/stdarg.h

@@ -34,6 +34,8 @@
 typedef char *va_list;
 #define va_start(ap, last) (void)((ap) = (char*)(&(last) + 1))
 #define va_arg(ap, type) (type)(((long*)((ap) = ((ap) + sizeof (void*))))[-1])
+#define va_align(ap, alignment) ((char*)((((unsigned long) (ap)) + (alignment) - 1) &~ ((alignment) - 1)))
+#define va_arg8(ap, type) (type)(((double*)((ap) = (va_align((ap), 8) + sizeof(double))))[-1])
 #define va_end(ap) (void)((ap) = 0)
 #define va_copy(dest, src) dest = src
 

include/stdlib.h

@@ -36,6 +36,7 @@ typedef int (*comparison_fn_t) (void const *, void const *);
 #include <sys/types.h>
 #include <alloca.h>
 
+void abort (void);
 double atof (char const *s);
 int atoi (char const *s);
 int atexit (void (*function) (void));

include/sys/stat.h

@@ -85,10 +85,12 @@ struct stat
 int chmod (char const *file_name, mode_t mode);
 int fstat (int filedes, struct stat *buf);
 int mkdir (char const *file_name, mode_t mode);
+int mknod (char const *file_name, mode_t mode, dev_t dev);
 int chown (char const *file_name, uid_t owner, gid_t group);
 int rmdir (char const *file_name);
 int stat (char const *file_name, struct stat *buf);
 
+#define S_IFIFO 0010000
 #define S_IFCHR 0020000
 #define S_IFDIR 0040000
 #define S_IFBLK 0060000
@@ -96,6 +98,7 @@ int stat (char const *file_name, struct stat *buf);
 #define S_IFLNK 0120000
 #define S_IFMT  0170000
 
+#define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
 #define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
 #define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
 

include/sys/types.h

@@ -87,7 +87,7 @@ typedef unsigned long uintptr_t;
 #ifndef __MES_OFF_T
 #define __MES_OFF_T
 #undef off_t
-typedef unsigned long off_t;
+typedef long off_t;
 #endif
 
 #ifndef __MES_OFF64_T
@@ -138,6 +138,15 @@ typedef long ssize_t;
 typedef unsigned uid_t;
 #endif
 
+#ifndef __WCHAR_T
+#define __WCHAR_T
+#ifndef __MES_WCHAR_T
+#define __MES_WCHAR_T
+#undef wchar_t
+typedef int wchar_t;
+#endif
+#endif
+
 #endif // ! SYSTEM_LIBC
 
 #endif // __MES_SYS_TYPES_H

include/termio.h

@@ -49,6 +49,14 @@
 #define   CS8	0000060
 #define PARENB	0000400
 
+struct winsize
+{
+  unsigned short ws_row;
+  unsigned short ws_col;
+  unsigned short ws_xpixel;
+  unsigned short ws_ypixel;
+};
+
 struct termio
 {
   unsigned short c_iflag;

include/time.h

@@ -59,6 +59,7 @@ struct timespec
 int clock_gettime (clockid_t clk_id, struct timespec *tp);
 struct tm *localtime (time_t const *timep);
 struct tm *gmtime (time_t const *time);
+time_t mktime (struct tm *broken_time);
 int nanosleep (struct timespec const *requested_time, struct timespec const *remaining);
 time_t time (time_t * tloc);
 

include/unistd.h

@@ -62,6 +62,7 @@ unsigned int alarm (unsigned int seconds);
 int close (int fd);
 int execv (char const *file_name, char *const argv[]);
 int execl (char const *file_name, char const *arg, ...);
+int execlp (char const *file_name, char const *arg, ...);
 int execve (char const *file, char *const argv[], char *const env[]);
 int execvp (char const *file, char *const argv[]);
 int fork (void);
@@ -73,21 +74,24 @@ int setgid (gid_t newgid);
 int setuid (uid_t newuid);
 uid_t geteuid (void);
 gid_t getegid (void);
+pid_t getpgrp (void);
 pid_t getpid (void);
 pid_t getppid (void);
+int getpgid (pid_t pid);
 int isatty (int fd);
-int link (char const *oldname, char const *newname);
+int link (char const *old_name, char const *new_name);
 off_t lseek (int fd, off_t offset, int whence);
 ssize_t read (int fd, void *buffer, size_t size);
+ssize_t readlink (char const *file_name, char *buffer, size_t size);
 #if __SBRK_CHAR_PTRDIFF
 /* xmalloc in binutils <= 2.10.1 uses this old prototype */
 char *sbrk (ptrdiff_t delta);
 #else
 void *sbrk (intptr_t delta);
 #endif
+int symlink (char const *old_name, char const *new_name);
 int unlink (char const *file_name);
 ssize_t write (int filedes, void const *buffer, size_t size);
-pid_t getpid (void);
 
 #endif // ! SYSTEM_LIBC
 

lib/ctype/isgraph.c

@@ -0,0 +1,27 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2019 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 <ctype.h>
+
+int
+isgraph (int c)
+{
+  return c > 32 && c < 127;
+}

lib/linux/mknod.c

@@ -0,0 +1,29 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2018,2019 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 <linux/syscall.h>
+#include <syscall.h>
+#include <sys/stat.h>
+
+int
+mknod (char const *file_name, mode_t mode, dev_t dev)
+{
+  return _sys_call3 (SYS_mknod, (long) file_name, (long) mode, (long) dev);
+}

lib/linux/readlink.c

@@ -0,0 +1,29 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2018,2019 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 <linux/syscall.h>
+#include <syscall.h>
+#include <sys/stat.h>
+
+ssize_t
+readlink (char const *file_name, char *buffer, size_t size)
+{
+  return _sys_call3 (SYS_readlink, (long) file_name, (long) buffer, (long) size);
+}

lib/linux/symlink.c

@@ -0,0 +1,29 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2018,2019 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 <linux/syscall.h>
+#include <syscall.h>
+#include <unistd.h>
+
+int
+symlink (char const *old_name, char const *new_name)
+{
+  return _sys_call2 (SYS_symlink, (long) old_name, (long) new_name);
+}

lib/m2/file_print.c

@@ -0,0 +1,130 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018 Jeremiah Orians <jeremiah@pdp10.guru>
+ *
+ * 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 <stdio.h>
+#include <unistd.h>
+
+// CONSTANT TRUE 1
+#define TRUE 1
+// CONSTANT FALSE 0
+#define FALSE 0
+
+int fdputc (int c, int fd);
+int fdputs (char const *s, int fd);
+
+/*
+void
+fd_print (char *s, int f)
+{
+  while (0 != s[0])
+    {
+      fdputc (s[0], f);
+      s = s + 1;
+    }
+}
+
+int
+fdputs (char const *s, int fd)
+{
+  fd_print ((char *) s, fd);
+  return 0;
+}
+*/
+
+int char2hex (int c);
+char block[4];
+char *
+char_lookup (int c, int type)
+{
+  static char *s = block;
+  s[0] = '\\';
+  if (type)
+    {
+      if (c == '\0')
+        return "\\nul";
+      else if (c == '\a')
+        return "\\alarm";
+      else if (c == '\b')
+        return "\\backspace";
+      else if (c == '\t')
+        return "\\tab";
+      else if (c == '\n')
+        return "\\newline";
+      else if (c == '\v')
+        return "\\vtab";
+      else if (c == '\f')
+        return "\\page";
+      else if (c == '\r')
+        return "\\return";
+      else if (c == ' ')
+        return "\\space";
+      else
+        {
+          s[1] = char2hex ((c & 0xF0) >> 4);
+          s[2] = char2hex (c & 0xF);
+        }
+    }
+  else
+    {
+      s[2] = 0;
+      if (c == '\0')
+        s[1] = '0';
+      else if (c == '\a')
+        s[1] = 'a';
+      else if (c == '\b')
+        s[1] = 'b';
+      else if (c == '\t')
+        s[1] = 't';
+      else if (c == '\v')
+        s[1] = 'v';
+      else if (c == '\n')
+        s[1] = 'n';
+      else if (c == '\f')
+        s[1] = 'f';
+      else if (c == '\r')
+        s[1] = 'r';
+      else if (c == '\e')
+        s[1] = 'e';
+      else if (c == '\\')
+        s[1] = '\\';
+      else if (c == '"')
+        s[1] = '"';
+      else
+        {
+          s[0] = c;
+          s[1] = 0;
+        }
+    }
+  return s;
+}
+
+void
+raw_print (char *s, int fd)
+{
+  while (0 != s[0])
+    {
+      /*
+      fd_print (char_lookup (s[0], FALSE), fd);
+      */
+      fdputs (char_lookup (s[0], FALSE), fd);
+      s = s + 1;
+    }
+}

lib/m2/in_set.c

@@ -0,0 +1,37 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018 Jeremiah Orians <jeremiah@pdp10.guru>
+ *
+ * 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/>.
+ */
+
+// CONSTANT TRUE 1
+#define TRUE 1
+// CONSTANT FALSE 0
+#define FALSE 0
+
+int
+in_set (int c, char *s)
+{
+  while (0 != s[0])
+    {
+      if (c == s[0])
+        return TRUE;
+      s = s + 1;
+    }
+  return FALSE;
+}

lib/m2/mes_open.c

@@ -0,0 +1,33 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018,2019 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 <mes/lib.h>
+#include <fcntl.h>
+#include <stdlib.h>
+
+int
+mes_open (char *file_name, int flags, int mask)
+{
+  __ungetc_init ();
+  int filedes = open (file_name, flags, mask);
+  if (filedes > 2)
+    __ungetc_clear (filedes);
+  return filedes;
+}

lib/m2/ntoab.c

@@ -0,0 +1,62 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians
+ *
+ * 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 <mes/lib.h>
+
+char *
+ntoab (SCM x, int base, int signed_p)
+{
+  static char itoa_buf[20];
+  char *p = itoa_buf + 11;
+  *p-- = 0;
+  int sign_p = 0;
+  SCM u = x;
+
+  if (signed_p && x < 0)
+    {
+      sign_p = 1;
+      u = -x;
+    }
+
+  do
+    {
+      SCM i = u % base;
+      if (i > 9)
+        {
+          *p = 'a' + i - 10;
+        }
+      else
+        {
+          *p = '0' + i;
+        }
+      p = p - 1;
+      u = u / base;
+    }
+  while (u);
+
+  if (sign_p && *(p + 1) != '0')
+    {
+      *p = '-';
+      p = p - 1;
+    }
+
+  return p + 1;
+}

lib/m2/numerate.c

@@ -0,0 +1,125 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018 Jeremiah Orians <jeremiah@pdp10.guru>
+ *
+ * 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/>.
+ */
+
+// CONSTANT TRUE 1
+#define TRUE 1
+// CONSTANT FALSE 0
+#define FALSE 0
+int in_set (int c, char *s);
+
+int
+char2hex (int c)
+{
+  if (c >= '0' && c <= '9')
+    return (c - 48);
+  else if (c >= 'a' && c <= 'f')
+    return (c - 87);
+  else if (c >= 'A' && c <= 'F')
+    return (c - 55);
+  else
+    return -1;
+}
+
+int
+index_number (char *s, char c)
+{
+  int i = 0;
+  while (s[i] != c)
+    {
+      i = i + 1;
+      if (0 == s[i])
+        return -1;
+    }
+  return i;
+}
+
+int
+toupper (int c)
+{
+  if (in_set (c, "abcdefghijklmnopqrstuvwxyz"))
+    return (c & 0xDF);
+  return c;
+}
+
+int
+set_reader (char *set, int mult, char *input)
+{
+  int n = 0;
+  int i = 0;
+  int hold;
+  int negative_p = 0;
+
+  if (input[0] == '-')
+    {
+      negative_p = 1;
+      i = i + 1;
+    }
+
+  while (in_set (input[i], set))
+    {
+      n = n * mult;
+      hold = index_number (set, toupper (input[i]));
+      if (-1 == hold)
+        return 0;
+      n = n + hold;
+      i = i + 1;
+    }
+
+  if (0 != input[i])
+    return 0;
+
+  if (negative_p)
+    {
+      n = 0 - n;
+    }
+
+  return n;
+}
+
+int
+numerate_string (char *a)
+{
+  /* If NULL string */
+  if (0 == a[0])
+    {
+      return 0;
+    }
+  /* Deal with binary */
+  else if ('0' == a[0] && 'b' == a[1])
+    {
+      return set_reader ("01", 2, a + 2);
+    }
+  /* Deal with hex */
+  else if ('0' == a[0] && 'x' == a[1])
+    {
+      return set_reader ("0123456789ABCDEFabcdef", 16, a + 2);
+    }
+  /* Deal with ocal */
+  else if ('0' == a[0])
+    {
+      return set_reader ("01234567", 8, a + 1);
+    }
+  /* Deal with decimal */
+  else
+    {
+      return set_reader ("0123456789", 10, a);
+    }
+}

lib/mes/abtod.c

@@ -0,0 +1,53 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018,2019 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 <mes/lib.h>
+
+double
+abtod (char const **p, int base)
+{
+  char const *s = *p;
+  double d = 0;
+  int sign_p = 0;
+  if (!base)
+    base = 10;
+  double dbase = base;
+  long i = abtol (&s, base);
+  long f = 0;
+  long e = 0;
+  if (*s == '.')
+    {
+      s++;
+      f = abtol (&s, base);
+    }
+  if (*s == 'e')
+    {
+      s++;
+      e = abtol (&s, base);
+    }
+  d = i + f / dbase;
+  if (e < 0)
+    while (e++)
+      d = d / dbase;
+  while (e--)
+    d = d * dbase;
+  *p = s;
+  return sign_p ? -d : d;
+}

lib/mes/abtol.c

@@ -26,12 +26,16 @@ abtol (char const **p, int base)
 {
   char const *s = *p;
   int i = 0;
-  int sign = 1;
+  int sign_p = 0;
   if (!base)
     base = 10;
+  while (isspace (*s))
+    s++;
+  if (*s && *s == '+')
+    s++;
   if (*s && *s == '-')
     {
-      sign = -1;
+      sign_p = 1;
       s++;
     }
   while (isnumber (*s, base))
@@ -42,5 +46,5 @@ abtol (char const **p, int base)
       s++;
     }
   *p = s;
-  return i * sign;
+  return sign_p ? -i : i;
 }

lib/mes/dtoab.c

@@ -0,0 +1,46 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018,2019 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 <mes/lib.h>
+#include <limits.h>
+#include <string.h>
+
+char *
+dtoab (double d, int base, int signed_p)
+{
+  static char dtoa_buf[40];
+  long i = (long) d;
+  char *p = ntoab (i, base, signed_p);
+  strcpy (dtoa_buf, p);
+  long f = (d - (double) i) * (double) 100000000;
+  if (f)
+    {
+      if (f < 0)
+        f = -f;
+      strcat (dtoa_buf, ".");
+      p = ntoab (f, base, 1);
+      strcat (dtoa_buf, p);
+      p = strchr (dtoa_buf, 0);
+      p--;
+      while (*p && *p == '0')
+        *p-- = 0;
+    }
+  return dtoa_buf;
+}

lib/posix/execl.c

@@ -23,22 +23,13 @@
 #include <unistd.h>
 
 int
-execl (char const *file_name, char const *arg, ...)
+vexec (char const *file_name, va_list ap)
 {
-  if (__mes_debug () > 2)
-    {
-      eputs ("execl ");
-      eputs (file_name);
-      eputs ("\n");
-    }
+  char *arg = va_arg (ap, char *);
   char *argv[1000];             // POSIX minimum 4096
   int i = 0;
 
-  va_list ap;
-  va_start (ap, arg);
-
-  argv[i++] = (char *)file_name;
-  arg = va_arg (ap, char const *);
+  argv[i++] = (char *) file_name;
   while (arg)
     {
       argv[i++] = arg;
@@ -57,3 +48,20 @@ execl (char const *file_name, char const *arg, ...)
   va_end (ap);
   return r;
 }
+
+int
+execl (char const *file_name, char const *arg, ...)
+{
+  va_list ap;
+  int r;
+  va_start (ap, arg);
+  if (__mes_debug () > 2)
+    {
+      eputs ("execl ");
+      eputs (file_name);
+      eputs ("\n");
+    }
+  r = vexec (file_name, ap);
+  va_end (ap);
+  return r;
+}

lib/posix/execlp.c

@@ -0,0 +1,47 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+#include <mes/lib.h>
+#include <errno.h>
+#include <stdarg.h>
+
+int
+execlp (char const *file_name, char const *arg, ...)
+{
+  va_list ap;
+  int r;
+  va_start (ap, arg);
+  if (file_name[0] != '/')
+    file_name = search_path (file_name);
+  if (__mes_debug () > 2)
+    {
+      eputs ("execlp ");
+      eputs (file_name ? file_name : "0");
+      eputs ("\n");
+    }
+  if (!file_name)
+    {
+      errno = ENOENT;
+      return -1;
+    }
+  r = vexec (file_name, ap);
+  va_end (ap);
+  return r;
+}

lib/stdio/fflush.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -25,5 +25,8 @@
 int
 fflush (FILE * stream)
 {
-  fsync ((long) stream);
+  int filedes = (long) stream;
+  if (filedes < 3)
+    return 0;
+  return fsync (filedes);
 }

lib/stdio/vfprintf.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -33,7 +33,7 @@ vfprintf (FILE * f, char const *format, va_list ap)
     if (*p != '%')
       {
         count++;
-        fputc (*p++, fd);
+        fputc (*p++, f);
       }
     else
       {
@@ -88,7 +88,7 @@ vfprintf (FILE * f, char const *format, va_list ap)
           {
           case '%':
             {
-              fputc (*p, fd);
+              fputc (*p, f);
               count++;
               break;
             }
@@ -96,7 +96,7 @@ vfprintf (FILE * f, char const *format, va_list ap)
             {
               char _c;
               _c = va_arg (ap, long);
-              fputc (_c, fd);
+              fputc (_c, f);
               break;
             }
           case 'd':
@@ -108,7 +108,7 @@ vfprintf (FILE * f, char const *format, va_list ap)
             {
               long d = va_arg (ap, long);
               int base = c == 'o' ? 8 : c == 'x' || c == 'X' ? 16 : 10;
-              char const *s = ntoab (d, base, c != 'u' && c != 'x' && c != 'X');
+              char *s = ntoab (d, base, c != 'u' && c != 'x' && c != 'X');
               if (c == 'X')
                 strupr (s);
               int length = strlen (s);
@@ -182,6 +182,50 @@ vfprintf (FILE * f, char const *format, va_list ap)
                 }
               break;
             }
+          case 'f':
+          case 'e':
+          case 'E':
+          case 'g':
+          case 'G':
+            {
+              double d = va_arg8 (ap, double);
+              char *s = dtoab (d, 10, 1);
+              if (c == 'E' || c == 'G')
+                strupr (s);
+              int length = strlen (s);
+              if (precision == -1)
+                precision = length;
+              if (!left_p)
+                {
+                  while (width-- > precision)
+                    {
+                      fputc (pad, f);
+                      count++;
+                    }
+                  while (precision > length)
+                    {
+                      fputc (' ', f);
+                      precision--;
+                      width--;
+                      count++;
+                    }
+                }
+              while (*s)
+                {
+                  if (precision-- <= 0)
+                    break;
+                  width--;
+                  fputc (*s++, f);
+                  count++;
+                }
+              while (width > 0)
+                {
+                  width--;
+                  fputc (pad, f);
+                  count++;
+                }
+              break;
+            }
           case 'n':
             {
               int *n = va_arg (ap, int *);

lib/stdio/vsnprintf.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -114,7 +114,7 @@ vsnprintf (char *str, size_t size, char const *format, va_list ap)
             {
               long d = va_arg (ap, long);
               int base = c == 'o' ? 8 : c == 'x' || c == 'X' ? 16 : 10;
-              char const *s = ntoab (d, base, c != 'u' && c != 'x' && c != 'X');
+              char *s = ntoab (d, base, c != 'u' && c != 'x' && c != 'X');
               if (c == 'X')
                 strupr (s);
               int length = strlen (s);
@@ -198,6 +198,55 @@ vsnprintf (char *str, size_t size, char const *format, va_list ap)
                 }
               break;
             }
+          case 'f':
+          case 'e':
+          case 'E':
+          case 'g':
+          case 'G':
+            {
+              double d = va_arg8 (ap, double);
+              char *s = dtoab (d, 10, 1);
+              if (c == 'E' || c == 'G')
+                strupr (s);
+              int length = strlen (s);
+              if (precision == -1)
+                precision = length;
+              if (!left_p)
+                {
+                  while (width-- > precision)
+                    {
+                      if (count < size)
+                        *str++ = pad;
+                      count++;
+                    }
+                  while (precision > length)
+                    {
+                      if (count < size)
+                        *str++ = ' ';
+                      precision--;
+                      width--;
+                      count++;
+                    }
+                }
+              while (*s)
+                {
+                  if (precision-- <= 0)
+                    break;
+                  width--;
+                  c = *s++;
+                  if (count < size)
+                    *str++ = c;
+                  count++;
+                }
+              while (width > 0)
+                {
+                  width--;
+                  if (count < size)
+                    *str++ = pad;
+                  count++;
+                }
+              break;
+            }
           case 'n':
             {
               int *n = va_arg (ap, int *);

lib/stdio/vsscanf.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -66,6 +66,17 @@ vsscanf (char const *s, char const *template, va_list ap)
               count++;
               break;
             }
+          case 'e':
+          case 'f':
+          case 'g':
+          case 'E':
+          case 'G':
+            {
+              float *f = va_arg (ap, float *);
+              *f = strtod (p, &p);
+              count++;
+              break;
+            }
           default:
             {
               eputs ("vsscanf: not supported: %:");

lib/stdlib/__exit.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -18,6 +18,8 @@
  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+#include <stdlib.h>
+
 int
 __exit (int status)
 {

lib/stdlib/abort.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -18,6 +18,8 @@
  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+#include <stdlib.h>
+
 void
 abort (void)
 {

lib/stdlib/atof.c

@@ -20,12 +20,9 @@
 
 #include <mes/lib.h>
 
-int
-atof (int x)
+double
+atof (char const *string)
 {
-  static int stub = 0;
-  if (__mes_debug () && !stub)
-    eputs ("atof stub\n");
-  stub = 1;
-  return 0;
+  char const *p = string;
+  return abtod (&p, 0);
 }

lib/stdlib/atoi.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -21,8 +21,8 @@
 #include <mes/lib.h>
 
 int
-atoi (char const *s)
+atoi (char const *string)
 {
-  char const *p = s;
+  char const *p = string;
   return abtol (&p, 0);
 }

lib/stdlib/mbstowcs.c

@@ -18,10 +18,10 @@
  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+#include <mes/lib.h>
+#include <stdio.h>
 #include <stdlib.h>
-
-#if !__MESC__
-typedef char wchar_t[];
+#include <string.h>
 
 size_t
 mbstowcs (wchar_t * wstring, char const *string, size_t size)
@@ -33,4 +33,3 @@ mbstowcs (wchar_t * wstring, char const *string, size_t size)
   strcpy (wstring, string);
   return strlen (string);
 }
-#endif

lib/stdlib/strtod.c

@@ -0,0 +1,41 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2017,2018,2019 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 <mes/lib.h>
+#include <stdlib.h>
+#include <string.h>
+
+double
+strtod (char const *string, char **tailptr)
+{
+  int base = 10;
+  if (!strncmp (string, "0x", 2))
+    {
+      string += 2;
+      base = 16;
+    }
+  if (tailptr)
+    {
+      *tailptr = (char *) string;
+      return abtod ((char const **) tailptr, base);
+    }
+  char **p = (char **) &string;
+  return abtod ((char const **) p, base);
+}

lib/string/bzero.c

@@ -21,8 +21,15 @@
 #include <stdlib.h>
 #include <string.h>
 
+#if BZERO_INT
 int
+#else
+void
+#endif
 bzero (void *block, size_t size)
 {
-  return (int) (long) memset (block, 0, size);
+#if BZERO_INT
+  return (int) (long)
+#endif
+    memset (block, 0, size);
 }

lib/string/index.c

@@ -20,8 +20,12 @@
 
 #include <string.h>
 
+#if INDEX_INT
 int
+#else
+char *
+#endif
 index (char const *s, int c)
 {
-  return (int) (long) strchr (s, c);
+  return strchr (s, c);
 }

lib/string/rindex.c

@@ -20,7 +20,11 @@
 
 #include <string.h>
 
+#if INDEX_INT
 int
+#else
+char *
+#endif
 rindex (char const *s, int c)
 {
   return strrchr (s, c);

lib/string/strcspn.c

@@ -23,7 +23,7 @@
 size_t
 strcspn (char const *string, char const *stopset)
 {
-  char *p = string;
+  char *p = (char *) string;
   while (*p)
     if (strchr (stopset, *p))
       break;

lib/string/strpbrk.c

@@ -23,7 +23,7 @@
 char *
 strpbrk (char const *string, char const *stopset)
 {
-  char *p = string;
+  char *p = (char *) string;
   while (*p)
     if (strchr (stopset, *p))
       break;

lib/stub/frexp.c

@@ -20,7 +20,7 @@
 
 #include <mes/lib.h>
 
-int
+double
 frexp (int x)
 {
   static int stub = 0;

lib/stub/getgrgid.c

@@ -0,0 +1,41 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2018,2019 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 <mes/lib.h>
+#include <errno.h>
+#include <grp.h>
+
+struct group *
+getgrgid (gid_t gid)
+{
+  static int stub = 0;
+  if (__mes_debug () && !stub)
+    eputs ("getgrid stub\n");
+  static char *groups[2] = { "root", 0 };
+#if SYSTEM_LIBC
+  static struct group root = { "root", 0, 0 };
+  root.gr_mem = groups;
+#else
+  static struct group root = { "root", 0, groups };
+#endif
+  stub = 1;
+  errno = 0;
+  return &root;
+}

lib/stub/getgrnam.c

@@ -0,0 +1,41 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2018,2019 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 <mes/lib.h>
+#include <errno.h>
+#include <grp.h>
+
+struct group *
+getgrnam (char const *name)
+{
+  static int stub = 0;
+  if (__mes_debug () && !stub)
+    eputs ("getgrid stub\n");
+  static char *groups[2] = { "root", 0 };
+#if SYSTEM_LIBC
+  static struct group root = { "root", 0, 0 };
+  root.gr_mem = groups;
+#else
+  static struct group root = { "root", 0, groups };
+#endif
+  stub = 1;
+  errno = 0;
+  return &root;
+}

lib/stub/getpgid.c

@@ -0,0 +1,34 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2019 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 <mes/lib.h>
+#include <errno.h>
+#include <unistd.h>
+
+int
+getpgid (pid_t pid)
+{
+  static int stub = 0;
+  if (__mes_debug () && !stub)
+    eputs ("getpgid stub\n");
+  stub = 1;
+  errno = 0;
+  return 0;
+}

lib/stub/getpgrp.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -19,14 +19,16 @@
  */
 
 #include <mes/lib.h>
-#include <stdlib.h>
+#include <errno.h>
+#include <unistd.h>
 
-double
-strtod (char const *string, char **tailptr)
+pid_t
+getpgrp (void)
 {
   static int stub = 0;
   if (__mes_debug () && !stub)
-    eputs ("strtod stub\n");
+    eputs ("getpgrp stub\n");
   stub = 1;
+  errno = 0;
   return 0;
 }

lib/stub/getpwnam.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -23,12 +23,13 @@
 #include <pwd.h>
 
 struct passwd *
-getpwnam (const char *NAME)
+getpwnam (const char *name)
 {
   static int stub = 0;
   if (__mes_debug () && !stub)
     eputs ("getpwnam stub\n");
   stub = 1;
   errno = 0;
-  return 0;
+  static struct passwd root = { "root", "*", 0, 0, "", "/root", "/bin/sh" };
+  return &root;
 }

lib/stub/getpwuid.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -30,5 +30,6 @@ getpwuid (uid_t uid)
     eputs ("getpwuid stub\n");
   stub = 1;
   errno = 0;
-  return 0;
+  static struct passwd root = { "root", "*", 0, 0, "", "/root", "/bin/sh" };
+  return &root;
 }

lib/stub/localtime.c

@@ -1,6 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  *
  * This file is part of GNU Mes.
  *
@@ -31,5 +31,6 @@ localtime (time_t const *timep)
     eputs ("localtime stub\n");
   stub = 1;
   errno = 0;
-  return 0;
+  static struct tm zero = { 0 };
+  return &zero;
 }

lib/stub/mktime.c

@@ -0,0 +1,34 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2018,2019 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 <mes/lib.h>
+#include <errno.h>
+#include <time.h>
+
+time_t
+mktime (struct tm *broken_time)
+{
+  static int stub = 0;
+  if (__mes_debug () && !stub)
+    eputs ("mktime stub\n");
+  stub = 1;
+  errno = 0;
+  return 0;
+}

lib/stub/setgrent.c

@@ -0,0 +1,32 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2018,2019 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 <mes/lib.h>
+#include <errno.h>
+
+void
+setgrent (void)
+{
+  static int stub = 0;
+  if (__mes_debug () && !stub)
+    eputs ("setgrent stub\n");
+  stub = 1;
+  errno = 0;
+}

lib/tests/mes/90-abtod.c

@@ -0,0 +1,34 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2019 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 <mes/lib.h>
+#include <stdlib.h>
+#include <stdio.h>
+
+int
+main ()
+{
+  char *s = "1.2e3";
+  char *p = s;
+  double d = abtod (&p, 0);
+  printf ("%f\n", d);
+
+  return 0;
+}

lib/tests/mes/90-abtod.stdout

@@ -0,0 +1 @@
+1200.000000

lib/tests/mes/90-dtoab.c

@@ -0,0 +1,36 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2019 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 <mes/lib.h>
+#include <stdlib.h>
+
+int
+main ()
+{
+  double d = 1.23;
+  char *p = dtoab (d, 10, 1);
+  puts (p);
+
+  d = -3.14159265;
+  p = dtoab (d, 10, 1);
+  puts (p);
+
+  return 0;
+}

lib/tests/mes/90-dtoab.stdout

@@ -0,0 +1,2 @@
+1.23
+-3.14159265

lib/tests/posix/90-execlp.c

@@ -0,0 +1,28 @@
+/* -*-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 "unistd.h"
+
+int
+main (int argc, char const *argv[])
+{
+  execlp ("echo", "echo", "Hello", "World!", 0);
+  return 0;
+}

lib/tests/posix/90-execlp.stdout

@@ -0,0 +1 @@
+Hello World!

lib/tests/stdio/90-sprintf.c

@@ -0,0 +1,44 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2019 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 <mes/lib.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+int
+main ()
+{
+  char buf[20];
+
+  int i = 0;
+  printf ("%3.6d\n", i);
+  sprintf (buf, "%3.6d", i);
+  puts (buf);
+
+  double d = 1;
+  printf ("%3.6f\n", d);
+  sprintf (buf, "%3.6f", d);
+  puts (buf);
+  printf ("%3.6g\n", d);
+  sprintf (buf, "%3.6g", d);
+  puts (buf);
+
+  return 0;
+}

lib/tests/stdio/90-sprintf.stdout

@@ -0,0 +1,6 @@
+000000
+000000
+1.000000
+1.000000
+  1
+  1

makefile

@@ -0,0 +1,296 @@
+## Copyright (C) 2019 Jeremiah Orians
+## 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/>.
+
+# Prevent rebuilding
+VPATH = bin:test:test/results
+
+CC = gcc
+M2_PLANET = M2-Planet
+
+CFLAGS:=					\
+  $(CFLAGS)					\
+ -D _GNU_SOURCE					\
+ -D const=					\
+ -ggdb						\
+ -D WITH_GLIBC=1				\
+ -D 'MES_VERSION="git"'				\
+ -D 'MES_PKGDATADIR="/usr/local/share/mes"'	\
+ -I include					\
+ -fno-builtin					\
+ -Wno-discarded-qualifiers			\
+ -Wno-discarded-array-qualifiers		\
+ -Wno-ignored-qualifiers			\
+ -Wno-incompatible-pointer-types		\
+ -Wno-int-conversion
+
+MES_SOURCES =					\
+ src/builtins.c					\
+ src/eval.c					\
+ src/gc.c					\
+ src/hash.c					\
+ src/init.c					\
+ src/lib.c					\
+ src/math.c					\
+ src/mes.c						\
+ src/module.c					\
+ src/posix.c					\
+ src/printer.c					\
+ src/reader.c					\
+ src/string.c					\
+ src/struct.c					\
+ src/vector.c
+
+LIB_SOURCES =					\
+ lib/mes/eputs.c				\
+ lib/mes/itoa.c
+
+M2_SOURCES =					\
+ lib/m2/mes_open.c				\
+ lib/m2/in_set.c				\
+ lib/m2/numerate.c				\
+
+M2_TODO =					\
+ lib/m2/file_print.c				\
+ lib/m2/ntoab.c					\
+ lib/mes/fdgetc.c				\
+ lib/mes/fdungetc.c
+
+SOURCES = $(M2_SOURCES) $(LIB_SOURCES) $(MES_SOURCES)
+INCLUDES =					\
+ include/mes/constants.h			\
+ include/mes/gcc.h				\
+ include/mes/mes.h
+
+GCC_SOURCES =					\
+ lib/m2/file_print.c				\
+ lib/mes/fdgetc.c				\
+ lib/mes/fdungetc.c				\
+ lib/mes/fdputc.c				\
+ lib/mes/fdputs.c				\
+ lib/mes/ntoab.c				\
+ $(SOURCES)
+
+mes-gcc: makefile $(GCC_SOURCES) $(INCLUDES) | bin
+	$(CC) $(CFLAGS) $(GCC_SOURCES) -o src/mes
+
+M2_PLANET_INCLUDES =				\
+ include/mes/mes.h				\
+ include/mes/m2.h				\
+ include/mes/constants.h
+
+M2_PLANET_PREFIX = ../M2-Planet
+M2_PLANET_SOURCES =						\
+ $(M2_PLANET_PREFIX)/test/common_amd64/functions/exit.c		\
+ $(M2_PLANET_PREFIX)/test/common_amd64/functions/malloc.c	\
+ $(M2_PLANET_PREFIX)/functions/calloc.c				\
+ $(M2_PLANET_INCLUDES)						\
+ $(SOURCES:%.c=%.m)
+
+$(info M2_PLANET_SOURCES: $(M2_PLANET_SOURCES))
+
+%.m: %.c makefile
+	@sed -r 's@^(#include.*)@/* \1 */@' $< > $*.im
+	@$(CC) -E -I include			\
+	    -D FUNCTION0=FUNCTION		\
+	    -D FUNCTION1=FUNCTION		\
+	    -D FUNCTION2=FUNCTION		\
+	    -D FUNCTION3=FUNCTION		\
+	    -D FUNCTIONN=FUNCTION		\
+	    -D const=				\
+	    -o $@ -x c $*.im
+
+mes-m2: makefile $(M2_PLANET_SOURCES) $(M2_PLANET_INCLUDES) | bin
+	$(M2_PLANET) $(M2_PLANET_FLAGS) $(M2_PLANET_SOURCES:%=-f %) -o bin/mes-m2 || rm -f bin/mes-m2
+
+# Clean up after ourselves
+.PHONY: clean
+clean:
+	rm -rf bin/ test/results/
+#	./test/test000/cleanup.sh
+
+# Directories
+bin:
+	mkdir -p bin
+
+results:
+	mkdir -p test/results
+
+# tests
+test: test000.answer \
+	test001.answer \
+	test100.answer \
+	test101.answer \
+	test102.answer \
+	test103.answer \
+	test105.answer \
+	test106.answer \
+	test109.answer \
+	test133.answer \
+	test200-binary | results
+	sha256sum -c test/test.answers
+#	test104.answer
+#	test107.answer
+#	test108.answer
+#	test110.answer
+#	test111.answer
+#	test112.answer
+#	test113.answer
+#	test114.answer
+#	test115.answer
+#	test116.answer
+#	test117.answer
+#	test118.answer
+#	test119.answer
+#	test120.answer
+#	test121.answer
+#	test122.answer
+#	test123.answer
+#	test124.answer
+#	test125.answer
+#	test126.answer
+#	test127.answer
+#	test128.answer
+#	test129.answer
+#	test130.answer
+#	test131.answer
+#	test132.answer
+
+test000.answer: results mes-m2
+	test/test000/hello.sh
+
+test001.answer: results mes-m2
+	test/test001/hello.sh
+
+test100.answer: results mes-m2
+	test/test100/hello.sh
+
+test101.answer: results mes-m2
+	test/test101/hello.sh
+
+test102.answer: results mes-m2
+	test/test102/hello.sh
+
+test103.answer: results mes-m2
+	test/test103/hello.sh
+
+test104.answer: results mes-m2
+	test/test104/hello.sh
+
+test105.answer: results mes-m2
+	test/test105/hello.sh
+
+test106.answer: results mes-m2
+	test/test106/hello.sh
+
+test107.answer: results mes-m2
+	test/test107/hello.sh
+
+test108.answer: results mes-m2
+	test/test108/hello.sh
+
+test109.answer: results mes-m2
+	test/test109/hello.sh
+
+test110.answer: results mes-m2
+	test/test110/hello.sh
+
+test111.answer: results mes-m2
+	test/test111/hello.sh
+
+test112.answer: results mes-m2
+	test/test112/hello.sh
+
+test113.answer: results mes-m2
+	test/test113/hello.sh
+
+test114.answer: results mes-m2
+	test/test114/hello.sh
+
+test115.answer: results mes-m2
+	test/test115/hello.sh
+
+test116.answer: results mes-m2
+	test/test116/hello.sh
+
+test117.answer: results mes-m2
+	test/test117/hello.sh
+
+test118.answer: results mes-m2
+	test/test118/hello.sh
+
+test119.answer: results mes-m2
+	test/test119/hello.sh
+
+test120.answer: results mes-m2
+	test/test120/hello.sh
+
+test121.answer: results mes-m2
+	test/test121/hello.sh
+
+test122.answer: results mes-m2
+	test/test122/hello.sh
+
+test123.answer: results mes-m2
+	test/test123/hello.sh
+
+test124.answer: results mes-m2
+	test/test124/hello.sh
+
+test125.answer: results mes-m2
+	test/test125/hello.sh
+
+test126.answer: results mes-m2
+	test/test126/hello.sh
+
+test127.answer: results mes-m2
+	test/test127/hello.sh
+
+test128.answer: results mes-m2
+	test/test128/hello.sh
+
+test129.answer: results mes-m2
+	test/test129/hello.sh
+
+test130.answer: results mes-m2
+	test/test130/hello.sh
+
+test131.answer: results mes-m2
+	test/test131/hello.sh
+
+test132.answer: results mes-m2
+	test/test132/hello.sh
+
+test133.answer: results mes-m2
+	test/test133/hello.sh
+
+test200-binary: results mes-m2
+	test/test200/hello.sh
+
+# Generate test answers
+.PHONY: Generate-test-answers
+Generate-test-answers:
+	sha256sum test/results/* >| test/test.answers
+
+DESTDIR:=
+PREFIX:=/usr/local
+bindir:=$(DESTDIR)$(PREFIX)/bin
+.PHONY: install
+install: mes-m2
+	mkdir -p $(bindir)
+	cp $^ $(bindir)
+
+TAGS:
+	etags $(shell find . -name '*.c' -o -name '*.h') --language=scheme $(shell find mes module -name '*.mes' -o -name '*.scm')

mes/module/mes/repl.mes

@@ -30,6 +30,7 @@
 (define welcome
   (string-append "GNU Mes " %version "
 Copyright (C) 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+Copyright (C) 2019 Jeremiah Orians <jeremiah@pdp10.guru>
 
 GNU Mes comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
 This program is free software, and you are welcome to redistribute it

scripts/m2-merge.scm.in

@@ -0,0 +1,191 @@
+#! @GUILE@ \
+--no-auto-compile -e main -L @guile_site_dir@ -C @guile_site_ccache_dir@ -s
+!#
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2019 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:
+
+;; src/mes is being rewritten to the simplified M2-Planet C subset (M2
+;; for short).  This rewrite is a joint undertaking that takes place in
+;; a separate repository (mes-m2), using a non-GNU coding style.
+
+;; This script means to maintain the history of the rewrite while
+;; being minimally disruptive to the GNU Mes repository.
+
+;; git filter-branch -f --tree-filter ~/src/mes/wip-m2-merge/scripts/m2-merge.scm HEAD
+
+;;; Code:
+
+(use-modules (srfi srfi-26)
+             (guix build utils))
+
+(define (m2->mes file-name)
+  (let ((m2->mes-alist '(("mes.c" . "src/mes.c")
+
+                         ("mes_builtins.c" . "src/builtins.c")
+                         ("mes_eval.c" . "src/eval.c")
+                         ("mes_gc.c" . "src/gc.c")
+                         ("mes_hash.c" . "src/hash.c")
+                         ("mes_init.c" . "src/init.c")
+                         ("mes_lib.c" . "src/lib.c")
+                         ("mes_math.c" . "src/math.c")
+                         ("mes_module.c" . "src/module.c")
+                         ("mes_posix.c" . "src/posix.c")
+                         ("mes_printer.c" . "src/printer.c")
+                         ("mes_reader.c" . "src/reader.c")
+                         ("mes_strings.c" . "src/string.c")
+                         ("mes_struct.c" . "src/struct.c")
+                         ("mes_vector.c" . "src/vector.c")
+                         ("temp.c" . "src/temp.c")
+
+                         ("libmes.c" . "lib/libmes.c")
+
+                         ("lib/builtins.c" . "src/builtins.c")
+                         ("lib/eval.c" . "src/eval.c")
+                         ("lib/gc.c" . "src/gc.c")
+                         ("lib/hash.c" . "src/hash.c")
+                         ("lib/lib.c" . "src/lib.c")
+                         ("lib/math.c" . "src/math.c")
+                         ("lib/mes.c" . "src/mes.c")
+                         ("lib/module.c" . "src/module.c")
+                         ("lib/posix.c" . "src/posix.c")
+                         ("lib/printer.c" . "src/printer.c")
+                         ("lib/reader.c" . "src/reader.c")
+                         ("lib/strings.c" . "src/string.c")
+                         ("lib/struct.c" . "src/struct.c")
+                         ("lib/vector.c" . "src/vector.c")
+
+                         ("include/libmes.h" . "include/mes/lib.h")
+                         ("include/libmes-mini.h" . "include/mes/lib-mini.h")
+
+                         ("lib/libmes.h" . "lib/mes/lib.h")
+                         ("lib/libmes-mini.h" . "lib/mes/lib-mini.h")
+                         ("lib/builtins.h" . "lib/mes/builtins.h")
+
+                         ("functions/eputs.c" . "lib/m2/eputs.c")
+                         ("functions/file_print.c" . "lib/m2/file_print.c")
+                         ("functions/in_set.c" . "lib/m2/in_set.c")
+                         ("functions/match.c" . "lib/m2/match.c")
+                         ("functions/mes_open.c" . "lib/m2/mes_open.c")
+                         ("functions/ntoab.c" . "lib/m2/ntoab.c")
+                         ("functions/numerate.c" . "lib/m2/numerate.c")
+
+                         ("mes_constants.h" . "include/mes/constants.h")
+                         ("gcc_req.h" . "include/gcc/mes.h")
+                         ("mes.h" . "include/mes/mes.h")
+                         ("mes2.h" . "include/mes/mes2.h")
+                         ("mes_macros.h" . "include/mes/macros.h"))))
+    (substitute* file-name
+      (("builtins\\.h") "mes/builtins.h")
+      (("gcc_req\\.h") "gcc/mes.h")
+      (("mes_constants\\.h") "mes/constants.h")
+      (("mes\\.h") "mes/mes.h")
+      (("mes2\\.h") "mes/mes2.h")
+      (("mes_macros\\.h") "mes/macros.h")
+
+      (("mes/mes/constants\\.h") "mes/constants.h")
+      (("mes/mes/mes_macros\\.h") "mes/macros.h")
+      (("mes/mes/mes\\.h") "mes/mes.h")
+      (("mes/mes/builtins\\.h") "mes/builtins.h")
+      (("mes/mes/mes2\\.h") "mes/mes2.h")
+      (("gcc/mes/mes\\.h") "gcc/mes.h")
+
+      (("libmes/mes\\.h") "mes/lib.h")
+      (("libmes-mini\\.h") "mes/lib-mini.h")
+
+      (("strings\\.c") "string.c")
+
+      (("lib/builtins\\.c") "src/builtins.c")
+      (("lib/eval\\.c") "src/eval.c")
+      (("lib/gc\\.c") "src/gc.c")
+      (("lib/hash\\.c") "src/hash.c")
+      (("lib/lib\\.c") "src/lib.c")
+      (("lib/math\\.c") "src/math.c")
+      (("lib/mes\\.c") "src/mes.c")
+      (("lib/module\\.c") "src/module.c")
+      (("lib/posix\\.c") "src/posix.c")
+      (("lib/printer\\.c") "src/printer.c")
+      (("lib/reader\\.c") "src/reader.c")
+      (("lib/string\\.c") "src/string.c")
+      (("lib/string\\.c") "src/string.c")
+      (("lib/strings\\.c") "src/string.c")
+      (("lib/struct\\.c") "src/struct.c")
+      (("lib/vector\\.c") "src/vector.c")
+
+      (("mes\\.c") "src/mes.c")
+      (("src/src/mes\\.c") "src/mes.c")
+      (("libsrc/mes\\.c") "libmes.c")
+
+      (("mes_builtins\\.c") "src/builtins.c")
+      (("mes_eval\\.c") "src/eval.c")
+      (("mes_gc\\.c") "src/gc.c")
+      (("mes_hash\\.c") "src/hash.c")
+      (("mes_init\\.c") "src/init.c")
+      (("mes_lib\\.c") "src/lib.c")
+      (("mes_math\\.c") "src/math.c")
+      (("mes_module\\.c") "src/module.c")
+      (("mes_posix\\.c") "src/posix.c")
+      (("mes_printer\\.c") "src/printer.c")
+      (("mes_reader\\.c") "src/reader.c")
+      (("mes_strings\\.c") "src/string.c")
+      (("mes_string\\.c") "src/string.c")
+      (("mes_struct\\.c") "src/struct.c")
+      (("mes_vector\\.c") "src/vector.c")
+      (("temp\\.c") "src/temp.c")
+      (("src/src/temp\\.c") "src/temp.c")
+
+      (("times/mes\\.h") "times.h")
+      (("tisrc/mes\\.c") "times.c")
+      (("mksrc/temp.c\\.c") "mktemp.c")
+
+      (("x86-mes/src/") "x86-mes/")
+      (("x86_64-mes/src/") "x86_64-mes/")
+      (("x86-mes-gcc/src/") "x86-mes-gcc/")
+      (("x86_64-mes-gcc/src/") "x86_64-mes-gcc/")
+
+      (("functions/eputs\\.c") "lib/m2/eputs.c")
+      (("functions/file_print\\.c") "lib/m2/file_print.c")
+      (("functions/in_set\\.c") "lib/m2/in_set.c")
+      (("functions/match\\.c") "lib/m2/match.c")
+      (("functions/mes_open\\.c") "lib/m2/mes_open.c")
+      (("functions/numerate\\.c") "lib/m2/numerate.c")
+      (("functions/ntoab\\.c") "lib/m2/ntoab.c"))
+    (and=> (assoc-ref m2->mes-alist file-name) (cut rename-file file-name <>))))
+
+(define (indent file-name)
+  ;; we don't want init_builtin, init_symbol to be broken...
+  (system* "indent" file-name "--no-tabs" "--honour-newlines" "--line-length" "110")
+  (delete-file (string-append file-name "~"))
+  file-name)
+
+(define (main args)
+  (format (current-error-port) "hello!\n")
+  (let* ((h-files (find-files "." "\\.h$"))
+         (c-files (find-files "." "\\.c$"))
+         (script-files (map (cut string-drop <> 2)
+                            (append (find-files "." "simple.sh")
+                                    (find-files "." "makefile"))))
+         (files (append c-files h-files))
+         (files (map (cut string-drop <> 2) files)))
+    (mkdir-p "include/gcc")
+    (mkdir-p "include/mes")
+    (mkdir-p "lib/m2")
+    (mkdir-p "src")
+    (for-each (compose m2->mes indent) files)
+    (for-each m2->mes script-files)))

scripts/mesar.in

@@ -1,4 +1,4 @@
-#! @BASH@
+#! @SHELL@
 
 # GNU Mes --- Maxwell Equations of Software
 # Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
@@ -27,11 +27,10 @@ archive=$2
 shift
 shift
 M1_archive=$(dirname "$archive")/$(basename "$archive" .a).s
-declare -a M1_objects
 for o in "$@"; do
-    ((i++))
-    M1_objects[$i]=$(dirname "$o")/$(basename "$o" .o).s
+    s=$(dirname "$o")/$(basename "$o" .o).s
+    M1_objects="$M1_objects $s"
 done
 mkdir -p $(dirname "$archive")
-cat "${M1_objects[@]}" > "$M1_archive"
+cat $M1_objects > "$M1_archive"
 cat "$@" > "$archive"

scripts/mescc.in

@@ -25,7 +25,10 @@ fi
 MES_ARENA=${MES_ARENA-100000000}
 export MES_ARENA
 
-MES_STACK=${MES_STACK-500000}
+MES_MAX_ARENA=${MES_MAX_ARENA-${MES_ARENA}}
+export MES_MAX_ARENA
+
+MES_STACK=${MES_STACK-10000000}
 export MES_STACK
 
 MES_PREFIX=${MES_PREFIX-@prefix@}

src/builtins.c

@@ -0,0 +1,668 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians
+ *
+ * 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 "mes/mes.h"
+
+/* Imported Functions */
+struct scm *gc_check ();
+struct scm *gc ();
+struct scm *hashq (struct scm *x, struct scm *size);
+struct scm *hash (struct scm *x, struct scm *size);
+struct scm *hashq_get_handle (struct scm *table, struct scm *key, struct scm *dflt);
+struct scm *hashq_ref (struct scm *table, struct scm *key, struct scm *dflt);
+struct scm *hash_ref_ (struct scm *table, struct scm *key, struct scm *dflt);
+struct scm *hashq_set_x_ (struct scm *table, struct scm *key, struct scm *value);
+struct scm *hash_table_printer (struct scm *table);
+struct scm *hash_set_x (struct scm *table, struct scm *key, struct scm *value);
+struct scm *make_hash_table (struct scm *x);
+struct scm *display_ (struct scm *x);
+struct scm *display_error_ (struct scm *x);
+struct scm *display_port_ (struct scm *x, struct scm *p);
+struct scm *write_ (struct scm *x);
+struct scm *write_error_ (struct scm *x);
+struct scm *write_port_ (struct scm *x, struct scm *p);
+struct scm *exit_ (struct scm *x);
+struct scm *frame_printer (struct scm *frame);
+struct scm *make_stack ();
+struct scm *stack_length (struct scm *stack);
+struct scm *stack_ref (struct scm *stack, struct scm *index);
+struct scm *xassq (struct scm *x, struct scm *a);
+struct scm *memq (struct scm *x, struct scm *a);
+struct scm *equal2_p (struct scm *a, struct scm *b);
+struct scm *last_pair (struct scm *x);
+struct scm *pair_p (struct scm *x);
+struct scm *greater_p (struct scm *x);
+struct scm *less_p (struct scm *x);
+struct scm *is_p (struct scm *x);
+struct scm *minus (struct scm *x);
+struct scm *plus (struct scm *x);
+struct scm *divide (struct scm *x);
+struct scm *modulo (struct scm *a, struct scm *b);
+struct scm *multiply (struct scm *x);
+struct scm *logand (struct scm *x);
+struct scm *logior (struct scm *x);
+struct scm *lognot (struct scm *x);
+struct scm *logxor (struct scm *x);
+struct scm *ash (struct scm *n, struct scm *count);
+struct scm *acons (struct scm *key, struct scm *value, struct scm *alist);
+struct scm *add_formals (struct scm *formals, struct scm *x);
+struct scm *append2 (struct scm *x, struct scm *y);
+struct scm *arity_ (struct scm *x);
+struct scm *assoc (struct scm *x, struct scm *a);
+struct scm *assq (struct scm *x, struct scm *a);
+struct scm *call (struct scm *fn, struct scm *x);
+struct scm *car_ (struct scm *x);
+struct scm *cdr_ (struct scm *x);
+struct scm *car (struct scm *x);
+struct scm *cdr (struct scm *x);
+struct scm *cons (struct scm *x, struct scm *y);
+struct scm *eq_p (struct scm *x, struct scm *y);
+struct scm *error (struct scm *key, struct scm *x);
+struct scm *eval_apply ();
+struct scm *length (struct scm *x);
+struct scm *list (struct scm *x);
+struct scm *macro_get_handle (struct scm *name);
+struct scm *make_cell (struct scm *type, struct scm *car, struct scm *cdr);
+struct scm *make_number (SCM n);
+struct scm *null_p (struct scm *x);
+struct scm *pairlis (struct scm *x, struct scm *y, struct scm *a);
+struct scm *reverse_x_ (struct scm *x, struct scm *t);
+struct scm *set_car_x (struct scm *x, struct scm *e);
+struct scm *set_cdr_x (struct scm *x, struct scm *e);
+struct scm *set_env_x (struct scm *x, struct scm *e, struct scm *a);
+struct scm *type_ (struct scm *x);
+struct scm *values (struct scm *x);
+struct scm *builtin_printer (struct scm *builtin);
+struct scm *make_module_type_ ();
+struct scm *module_printer (struct scm *module);
+struct scm *module_variable_ (struct scm *module, struct scm *name);
+struct scm *module_ref_ (struct scm *module, struct scm *name);
+struct scm *module_define_x (struct scm *module, struct scm *name, struct scm *value);
+struct scm *peek_byte ();
+struct scm *read_byte ();
+struct scm *unread_byte (struct scm *i);
+struct scm *peek_char ();
+struct scm *read_char (struct scm *port);
+struct scm *unread_char (struct scm *i);
+struct scm *write_char (struct scm *i);
+struct scm *write_byte (struct scm *x);
+struct scm *getenv_ (struct scm *s);
+struct scm *setenv_ (struct scm *s, struct scm *v);
+struct scm *access_p (struct scm *file_name, struct scm *mode);
+struct scm *current_input_port ();
+struct scm *open_input_file (struct scm *file_name);
+struct scm *open_input_string (struct scm *string);
+struct scm *set_current_input_port (struct scm *port);
+struct scm *current_output_port ();
+struct scm *current_error_port ();
+struct scm *open_output_file (struct scm *x);
+struct scm *set_current_output_port (struct scm *port);
+struct scm *set_current_error_port (struct scm *port);
+struct scm *chmod_ (struct scm *file_name, struct scm *mode);
+struct scm *isatty_p (struct scm *port);
+struct scm *primitive_fork ();
+struct scm *execl_ (struct scm *file_name, struct scm *args);
+struct scm *waitpid_ (struct scm *pid, struct scm *options);
+struct scm *current_time ();
+struct scm *gettimeofday_ ();
+struct scm *get_internal_run_time ();
+struct scm *getcwd_ ();
+struct scm *dup_ (struct scm *port);
+struct scm *dup2_ (struct scm *old, struct scm *new);
+struct scm *delete_file (struct scm *file_name);
+struct scm *read_input_file_env_ (struct scm *e, struct scm *a);
+struct scm *read_input_file_env ();
+struct scm *read_env (struct scm *a);
+struct scm *reader_read_sexp (struct scm *c, struct scm *a);
+struct scm *reader_read_character ();
+struct scm *reader_read_binary ();
+struct scm *reader_read_octal ();
+struct scm *reader_read_hex ();
+struct scm *reader_read_string ();
+struct scm *string_equal_p_ (struct scm *a, struct scm *b);
+struct scm *symbol_to_string_ (struct scm *symbol);
+struct scm *symbol_to_keyword_ (struct scm *symbol);
+struct scm *keyword_to_string (struct scm *keyword);
+struct scm *string_to_symbol (struct scm *string);
+struct scm *make_symbol_ (struct scm *string);
+struct scm *string_to_list (struct scm *string);
+struct scm *list_to_string (struct scm *list);
+struct scm *read_string (struct scm *port);
+struct scm *string_append (struct scm *x);
+struct scm *string_length (struct scm *string);
+struct scm *string_ref (struct scm *str, struct scm *k);
+struct scm *make_struct (struct scm *type, struct scm *fields, struct scm *printer);
+struct scm *struct_length (struct scm *x);
+struct scm *struct_ref (struct scm *x, struct scm *i);
+struct scm *struct_set_x (struct scm *x, struct scm *i, struct scm *e);
+struct scm *make_vector_ (struct scm *n);
+struct scm *vector_length (struct scm *x);
+struct scm *vector_ref (struct scm *x, struct scm *i);
+struct scm *vector_set_x (struct scm *x);
+struct scm *list_to_vector (struct scm *x);
+struct scm *vector_to_list (struct scm *v);
+struct scm *init_time (struct scm *a);
+
+/* Internal functions required*/
+struct scm *make_string (char *s, int length);
+struct scm *make_struct (struct scm *type, struct scm *fields, struct scm *printer);
+struct scm *make_string_ (char *s);
+struct scm *cstring_to_symbol (char *s);
+struct scm *symbol_to_string (struct scm *symbol);
+int fdputc (int c, int fd);
+int fdputs (char *s, int fd);
+int eputs (char *s);
+int string_len (char *a);
+
+void
+init_symbol (struct scm *x, SCM type, char *name)
+{
+  struct scm *y = x;
+  y->type = type;
+  int l = string_len (name);
+  struct scm *string = make_string (name, l);
+  y->length = l;
+  y->string = string->string;
+  hash_set_x (g_symbols, string, x);
+}
+
+struct scm *
+mes_symbols ()                  /*((internal)) */
+{
+  g_symbol_max = g_free;
+  g_symbols = make_hash_table_ (500);
+  init_symbol (cell_nil, TSPECIAL, "()");
+  init_symbol (cell_f, TSPECIAL, "#f");
+  init_symbol (cell_t, TSPECIAL, "#t");
+  init_symbol (cell_dot, TSPECIAL, ".");
+  init_symbol (cell_arrow, TSPECIAL, "=>");
+  init_symbol (cell_undefined, TSPECIAL, "*undefined*");
+  init_symbol (cell_unspecified, TSPECIAL, "*unspecified*");
+  init_symbol (cell_closure, TSPECIAL, "*closure*");
+  init_symbol (cell_circular, TSPECIAL, "*circular*");
+  init_symbol (cell_begin, TSPECIAL, "*begin*");
+  init_symbol (cell_call_with_current_continuation, TSPECIAL, "*call/cc*");
+  init_symbol (cell_vm_apply, TSPECIAL, "core:apply");
+  init_symbol (cell_vm_apply2, TSPECIAL, "*vm-apply2*");
+  init_symbol (cell_vm_begin, TSPECIAL, "*vm-begin*");
+  init_symbol (cell_vm_begin_eval, TSPECIAL, "*vm:begin-eval*");
+  init_symbol (cell_vm_begin_expand, TSPECIAL, "core:eval");
+  init_symbol (cell_vm_begin_expand_eval, TSPECIAL, "*vm:begin-expand-eval*");
+  init_symbol (cell_vm_begin_expand_macro, TSPECIAL, "*vm:begin-expand-macro*");
+  init_symbol (cell_vm_begin_expand_primitive_load, TSPECIAL, "*vm:core:begin-expand-primitive-load*");
+  init_symbol (cell_vm_begin_primitive_load, TSPECIAL, "*vm:core:begin-primitive-load*");
+  init_symbol (cell_vm_begin_read_input_file, TSPECIAL, "*vm-begin-read-input-file*");
+  init_symbol (cell_vm_call_with_current_continuation2, TSPECIAL, "*vm-call-with-current-continuation2*");
+  init_symbol (cell_vm_call_with_values2, TSPECIAL, "*vm-call-with-values2*");
+  init_symbol (cell_vm_eval, TSPECIAL, "core:eval-expanded");
+  init_symbol (cell_vm_eval2, TSPECIAL, "*vm-eval2*");
+  init_symbol (cell_vm_eval_check_func, TSPECIAL, "*vm-eval-check-func*");
+  init_symbol (cell_vm_eval_define, TSPECIAL, "*vm-eval-define*");
+  init_symbol (cell_vm_eval_macro_expand_eval, TSPECIAL, "*vm:eval-macro-expand-eval*");
+  init_symbol (cell_vm_eval_macro_expand_expand, TSPECIAL, "*vm:eval-macro-expand-expand*");
+  init_symbol (cell_vm_eval_pmatch_car, TSPECIAL, "*vm-eval-pmatch-car*");
+  init_symbol (cell_vm_eval_pmatch_cdr, TSPECIAL, "*vm-eval-pmatch-cdr*");
+  init_symbol (cell_vm_eval_set_x, TSPECIAL, "*vm-eval-set!*");
+  init_symbol (cell_vm_evlis, TSPECIAL, "*vm-evlis*");
+  init_symbol (cell_vm_evlis2, TSPECIAL, "*vm-evlis2*");
+  init_symbol (cell_vm_evlis3, TSPECIAL, "*vm-evlis3*");
+  init_symbol (cell_vm_if, TSPECIAL, "*vm-if*");
+  init_symbol (cell_vm_if_expr, TSPECIAL, "*vm-if-expr*");
+  init_symbol (cell_vm_macro_expand, TSPECIAL, "core:macro-expand");
+  init_symbol (cell_vm_macro_expand_car, TSPECIAL, "*vm:core:macro-expand-car*");
+  init_symbol (cell_vm_macro_expand_cdr, TSPECIAL, "*vm:macro-expand-cdr*");
+  init_symbol (cell_vm_macro_expand_define, TSPECIAL, "*vm:core:macro-expand-define*");
+  init_symbol (cell_vm_macro_expand_define_macro, TSPECIAL, "*vm:core:macro-expand-define-macro*");
+  init_symbol (cell_vm_macro_expand_lambda, TSPECIAL, "*vm:core:macro-expand-lambda*");
+  init_symbol (cell_vm_macro_expand_set_x, TSPECIAL, "*vm:core:macro-expand-set!*");
+  init_symbol (cell_vm_return, TSPECIAL, "*vm-return*");
+  init_symbol (cell_symbol_dot, TSYMBOL, "*dot*");
+  init_symbol (cell_symbol_lambda, TSYMBOL, "lambda");
+  init_symbol (cell_symbol_begin, TSYMBOL, "begin");
+  init_symbol (cell_symbol_if, TSYMBOL, "if");
+  init_symbol (cell_symbol_quote, TSYMBOL, "quote");
+  init_symbol (cell_symbol_define, TSYMBOL, "define");
+  init_symbol (cell_symbol_define_macro, TSYMBOL, "define-macro");
+  init_symbol (cell_symbol_quasiquote, TSYMBOL, "quasiquote");
+  init_symbol (cell_symbol_unquote, TSYMBOL, "unquote");
+  init_symbol (cell_symbol_unquote_splicing, TSYMBOL, "unquote-splicing");
+  init_symbol (cell_symbol_syntax, TSYMBOL, "syntax");
+  init_symbol (cell_symbol_quasisyntax, TSYMBOL, "quasisyntax");
+  init_symbol (cell_symbol_unsyntax, TSYMBOL, "unsyntax");
+  init_symbol (cell_symbol_unsyntax_splicing, TSYMBOL, "unsyntax-splicing");
+  init_symbol (cell_symbol_set_x, TSYMBOL, "set!");
+  init_symbol (cell_symbol_sc_expand, TSYMBOL, "sc-expand");
+  init_symbol (cell_symbol_macro_expand, TSYMBOL, "macro-expand");
+  init_symbol (cell_symbol_portable_macro_expand, TSYMBOL, "portable-macro-expand");
+  init_symbol (cell_symbol_sc_expander_alist, TSYMBOL, "*sc-expander-alist*");
+  init_symbol (cell_symbol_call_with_values, TSYMBOL, "call-with-values");
+  init_symbol (cell_symbol_call_with_current_continuation, TSYMBOL, "call-with-current-continuation");
+  init_symbol (cell_symbol_boot_module, TSYMBOL, "boot-module");
+  init_symbol (cell_symbol_current_module, TSYMBOL, "current-module");
+  init_symbol (cell_symbol_primitive_load, TSYMBOL, "primitive-load");
+  init_symbol (cell_symbol_read_input_file, TSYMBOL, "read-input-file");
+  init_symbol (cell_symbol_write, TSYMBOL, "write");
+  init_symbol (cell_symbol_display, TSYMBOL, "display");
+  init_symbol (cell_symbol_car, TSYMBOL, "car");
+  init_symbol (cell_symbol_cdr, TSYMBOL, "cdr");
+  init_symbol (cell_symbol_not_a_number, TSYMBOL, "not-a-number");
+  init_symbol (cell_symbol_not_a_pair, TSYMBOL, "not-a-pair");
+  init_symbol (cell_symbol_system_error, TSYMBOL, "system-error");
+  init_symbol (cell_symbol_throw, TSYMBOL, "throw");
+  init_symbol (cell_symbol_unbound_variable, TSYMBOL, "unbound-variable");
+  init_symbol (cell_symbol_wrong_number_of_args, TSYMBOL, "wrong-number-of-args");
+  init_symbol (cell_symbol_wrong_type_arg, TSYMBOL, "wrong-type-arg");
+  init_symbol (cell_symbol_buckets, TSYMBOL, "buckets");
+  init_symbol (cell_symbol_builtin, TSYMBOL, "<builtin>");
+  init_symbol (cell_symbol_frame, TSYMBOL, "<frame>");
+  init_symbol (cell_symbol_hashq_table, TSYMBOL, "<hashq-table>");
+  init_symbol (cell_symbol_module, TSYMBOL, "<module>");
+  init_symbol (cell_symbol_procedure, TSYMBOL, "procedure");
+  init_symbol (cell_symbol_record_type, TSYMBOL, "<record-type>");
+  init_symbol (cell_symbol_size, TSYMBOL, "size");
+  init_symbol (cell_symbol_stack, TSYMBOL, "<stack>");
+  init_symbol (cell_symbol_argv, TSYMBOL, "%argv");
+  init_symbol (cell_symbol_mes_datadir, TSYMBOL, "%datadir");
+  init_symbol (cell_symbol_mes_version, TSYMBOL, "%version");
+  init_symbol (cell_symbol_internal_time_units_per_second, TSYMBOL, "internal-time-units-per-second");
+  init_symbol (cell_symbol_compiler, TSYMBOL, "%compiler");
+  init_symbol (cell_symbol_arch, TSYMBOL, "%arch");
+  init_symbol (cell_symbol_pmatch_car, TSYMBOL, "pmatch-car");
+  init_symbol (cell_symbol_pmatch_cdr, TSYMBOL, "pmatch-cdr");
+  init_symbol (cell_type_bytes, TSYMBOL, "<cell:bytes>");
+  init_symbol (cell_type_char, TSYMBOL, "<cell:char>");
+  init_symbol (cell_type_closure, TSYMBOL, "<cell:closure>");
+  init_symbol (cell_type_continuation, TSYMBOL, "<cell:continuation>");
+  init_symbol (cell_type_function, TSYMBOL, "<cell:function>");
+  init_symbol (cell_type_keyword, TSYMBOL, "<cell:keyword>");
+  init_symbol (cell_type_macro, TSYMBOL, "<cell:macro>");
+  init_symbol (cell_type_number, TSYMBOL, "<cell:number>");
+  init_symbol (cell_type_pair, TSYMBOL, "<cell:pair>");
+  init_symbol (cell_type_port, TSYMBOL, "<cell:port>");
+  init_symbol (cell_type_ref, TSYMBOL, "<cell:ref>");
+  init_symbol (cell_type_special, TSYMBOL, "<cell:special>");
+  init_symbol (cell_type_string, TSYMBOL, "<cell:string>");
+  init_symbol (cell_type_struct, TSYMBOL, "<cell:struct>");
+  init_symbol (cell_type_symbol, TSYMBOL, "<cell:symbol>");
+  init_symbol (cell_type_values, TSYMBOL, "<cell:values>");
+  init_symbol (cell_type_variable, TSYMBOL, "<cell:variable>");
+  init_symbol (cell_type_vector, TSYMBOL, "<cell:vector>");
+  init_symbol (cell_type_broken_heart, TSYMBOL, "<cell:broken-heart>");
+  init_symbol (cell_symbol_test, TSYMBOL, "%%test");
+  struct scm *a = cell_nil;
+  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_ (MES_VERSION), a);
+  a = acons (cell_symbol_mes_datadir, make_string_ (g_datadir), a);
+  a = acons (cell_type_bytes, make_number (TBYTES), 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_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;
+}
+
+struct scm *
+make_builtin (struct scm *builtin_type, struct scm *name, struct scm *arity, struct scm *function)
+{
+  struct scm *v = cell_nil;
+  v = cons (function, v);
+  v = cons (arity, v);
+  v = cons (name, v);
+  v = cons (cell_symbol_builtin, v);
+  return make_struct (builtin_type, v, cstring_to_symbol ("builtin-printer"));
+}
+
+struct scm *
+make_builtin_type ()            /* (internal) */
+{
+  struct scm *fields = cell_nil;
+  fields = cons (cstring_to_symbol ("address"), fields);
+  fields = cons (cstring_to_symbol ("arity"), fields);
+  fields = cons (cstring_to_symbol ("name"), fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_builtin, fields);
+  return make_struct (cell_symbol_record_type, fields, cell_unspecified);
+}
+
+struct scm *
+init_builtin (struct scm *builtin_type, char *name, int arity, FUNCTION function, struct scm *a)
+{
+  struct scm *s = cstring_to_symbol (name);
+  return acons (s,
+                make_builtin (builtin_type, symbol_to_string (s), make_number (arity),
+                              make_number (function)), a);
+}
+
+struct scm *
+builtin_name (struct scm *builtin)
+{
+  struct scm *x = builtin->cdr + (3 * CELL_SIZE);
+  return x->car;
+}
+
+struct scm *
+builtin_arity (struct scm *builtin)
+{
+  struct scm *x = builtin->cdr + (4 * CELL_SIZE);
+  return make_number (x->value);
+}
+
+void *
+builtin_function (struct scm *builtin)
+{
+  struct scm *x = builtin->cdr + (5 * CELL_SIZE);
+  return x->cdr;
+}
+
+struct scm *
+builtin_p (struct scm *x)
+{
+  struct scm *y = x->cdr + (2 * CELL_SIZE);
+  if (x->type == TSTRUCT && cell_symbol_builtin == y->car)
+    return cell_t;
+  return cell_f;
+}
+
+struct scm *
+builtin_printer (struct scm *builtin)
+{
+  fdputs ("#<procedure ", __stdout);
+  display_ (builtin_name (builtin));
+  fdputc (' ', __stdout);
+  int arity = builtin_arity (builtin)->value;
+
+  if (arity == -1)
+    {
+      fdputc ('_', __stdout);
+    }
+  else
+    {
+      fdputc ('(', __stdout);
+
+      int i;
+      for (i = 0; i < arity; i = i + 1)
+        {
+          if (i)
+            {
+              fdputc (' ', __stdout);
+            }
+
+          fdputc ('_', __stdout);
+        }
+    }
+
+  fdputc ('>', __stdout);
+  return cell_unspecified;
+}
+
+struct scm *
+apply_builtin (struct scm *fn, struct scm *x)   /* ((internal)) */
+{
+  int arity = (fn->cdr + (4 * CELL_SIZE))->value;
+
+  if (arity == 0)
+    {
+      FUNCTION *fp = builtin_function (fn);
+      return fp ();
+    }
+  else if (arity == 1)
+    {
+      if (x != cell_nil && x->car->type == TVALUES)
+        {
+          x = cons (x->car->cdr->car, x->cdr);
+        }
+
+      FUNCTION1 *fp = builtin_function (fn);
+      return fp (x->car);
+    }
+  else if (arity == 2)
+    {
+      if (x != cell_nil && x->car->type == TVALUES)
+        {
+          x = cons (x->car->cdr->car, x->cdr);
+        }
+
+      if (x != cell_nil && x->cdr->type == TPAIR)
+        {
+          if (x->cdr->car->type == TVALUES)
+            {
+              x = cons (x->car, cons (x->cdr->car->cdr->car, x->cdr));
+            }
+        }
+
+      FUNCTION2 *fp = builtin_function (fn);
+      return fp (x->car, x->cdr->car);
+    }
+  else if (arity == 3)
+    {
+      if (x != cell_nil && x->car->type == TVALUES)
+        {
+          x = cons (x->car->cdr->car, x->cdr);
+        }
+
+      if (x != cell_nil && x->cdr->type == TPAIR)
+        {
+          if (x->cdr->car->type == TVALUES)
+            {
+              x = cons (x->car, cons (x->cdr->car->cdr->car, x->cdr));
+            }
+        }
+
+      FUNCTION3 *fp = builtin_function (fn);
+      return fp (x->car, x->cdr->car, x->cdr->cdr->car);
+    }
+  else if (arity == -1)
+    {
+      if (x != cell_nil && x->car->type == TVALUES)
+        {
+          x = cons (x->car->cdr->car, x->cdr);
+        }
+
+      if (x != cell_nil && x->cdr->type == TPAIR)
+        {
+          if (x->cdr->car->type == TVALUES)
+            {
+              x = cons (x->car, cons (x->cdr->car->cdr->car, x->cdr));
+            }
+        }
+
+      FUNCTION1 *fp = builtin_function (fn);
+      return fp (x);
+    }
+
+  return cell_unspecified;
+}
+
+
+struct scm *
+mes_builtins (struct scm *a)    ///((internal))
+{
+  // TODO minimal: cons, car, cdr, list, null_p, eq_p minus, plus,  display_, display_error_, getenv
+  struct scm *builtin_type = make_builtin_type ();
+  /* src/gc.mes */
+  a = init_builtin (builtin_type, "gc-check", 0, &gc_check, a);
+  a = init_builtin (builtin_type, "gc", 0, &gc, a);
+  /* src/hash.mes */
+  a = init_builtin (builtin_type, "hashq", 2, &hashq, a);
+  a = init_builtin (builtin_type, "hash", 2, &hash, a);
+  a = init_builtin (builtin_type, "hashq-get-handle", 3, &hashq_get_handle, a);
+  a = init_builtin (builtin_type, "hashq-ref", 3, &hashq_ref, a);
+  a = init_builtin (builtin_type, "hash-ref", 3, &hash_ref_, a);
+  a = init_builtin (builtin_type, "hashq-set!", 3, &hashq_set_x_, a);
+  a = init_builtin (builtin_type, "hash-set!", 3, &hash_set_x, a);
+  a = init_builtin (builtin_type, "hash-table-printer", 1, &hash_table_printer, a);
+  a = init_builtin (builtin_type, "make-hash-table", 1, &make_hash_table, a);
+  /* src/lib.mes */
+  a = init_builtin (builtin_type, "core:display", 1, &display_, a);
+  a = init_builtin (builtin_type, "core:display-error", 1, &display_error_, a);
+  a = init_builtin (builtin_type, "core:display-port", 2, &display_port_, a);
+  a = init_builtin (builtin_type, "core:write", 1, &write_, a);
+  a = init_builtin (builtin_type, "core:write-error", 1, &write_error_, a);
+  a = init_builtin (builtin_type, "core:write-port", 2, &write_port_, a);
+  a = init_builtin (builtin_type, "exit", 1, &exit_, a);
+  a = init_builtin (builtin_type, "frame-printer", 1, &frame_printer, a);
+  a = init_builtin (builtin_type, "make-stack", -1, &make_stack, a);
+  a = init_builtin (builtin_type, "stack-length", 1, &stack_length, a);
+  a = init_builtin (builtin_type, "stack-ref", 2, &stack_ref, a);
+  a = init_builtin (builtin_type, "xassq", 2, &xassq, a);
+  a = init_builtin (builtin_type, "memq", 2, &memq, a);
+  a = init_builtin (builtin_type, "equal2?", 2, &equal2_p, a);
+  a = init_builtin (builtin_type, "last-pair", 1, &last_pair, a);
+  a = init_builtin (builtin_type, "pair?", 1, &pair_p, a);
+  /* src/math.mes */
+  a = init_builtin (builtin_type, ">", -1, &greater_p, a);
+  a = init_builtin (builtin_type, "<", -1, &less_p, a);
+  a = init_builtin (builtin_type, "=", -1, &is_p, a);
+  a = init_builtin (builtin_type, "-", -1, &minus, a);
+  a = init_builtin (builtin_type, "+", -1, &plus, a);
+  a = init_builtin (builtin_type, "/", -1, &divide, a);
+  a = init_builtin (builtin_type, "modulo", 2, &modulo, a);
+  a = init_builtin (builtin_type, "*", -1, &multiply, a);
+  a = init_builtin (builtin_type, "logand", -1, &logand, a);
+  a = init_builtin (builtin_type, "logior", -1, &logior, a);
+  a = init_builtin (builtin_type, "lognot", 1, &lognot, a);
+  a = init_builtin (builtin_type, "logxor", -1, &logxor, a);
+  a = init_builtin (builtin_type, "ash", 2, &ash, a);
+  /* src/mes.mes */
+  a = init_builtin (builtin_type, "core:make-cell", 3, &make_cell, a);
+  a = init_builtin (builtin_type, "core:type", 1, &type_, a);
+  a = init_builtin (builtin_type, "core:car", 1, &car_, a);
+  a = init_builtin (builtin_type, "core:cdr", 1, &cdr_, a);
+  a = init_builtin (builtin_type, "cons", 2, &cons, a);
+  a = init_builtin (builtin_type, "car", 1, &car, a);
+  a = init_builtin (builtin_type, "cdr", 1, &cdr, a);
+  a = init_builtin (builtin_type, "list", -1, &list, a);
+  a = init_builtin (builtin_type, "null?", 1, &null_p, a);
+  a = init_builtin (builtin_type, "eq?", 2, &eq_p, a);
+  a = init_builtin (builtin_type, "values", -1, &values, a);
+  a = init_builtin (builtin_type, "acons", 3, &acons, a);
+  a = init_builtin (builtin_type, "length", 1, &length, a);
+  a = init_builtin (builtin_type, "error", 2, &error, a);
+  a = init_builtin (builtin_type, "append2", 2, &append2, a);
+  a = init_builtin (builtin_type, "core:reverse!", 2, &reverse_x_, a);
+  a = init_builtin (builtin_type, "pairlis", 3, &pairlis, a);
+  a = init_builtin (builtin_type, "assq", 2, &assq, a);
+  a = init_builtin (builtin_type, "assoc", 2, &assoc, a);
+  a = init_builtin (builtin_type, "set-car!", 2, &set_car_x, a);
+  a = init_builtin (builtin_type, "set-cdr!", 2, &set_cdr_x, a);
+  a = init_builtin (builtin_type, "set-env!", 3, &set_env_x, a);
+  a = init_builtin (builtin_type, "macro-get-handle", 1, &macro_get_handle, a);
+  a = init_builtin (builtin_type, "add-formals", 2, &add_formals, a);
+  a = init_builtin (builtin_type, "eval-apply", 0, &eval_apply, a);
+  a = init_builtin (builtin_type, "make-builtin-type", 0, &make_builtin_type, a);
+  a = init_builtin (builtin_type, "make-builtin", 4, &make_builtin, a);
+  a = init_builtin (builtin_type, "builtin-name", 1, &builtin_name, a);
+  a = init_builtin (builtin_type, "builtin-arity", 1, &builtin_arity, a);
+  a = init_builtin (builtin_type, "builtin?", 1, &builtin_p, a);
+  a = init_builtin (builtin_type, "builtin-printer", 1, &builtin_printer, a);
+  /* src/module.mes */
+  a = init_builtin (builtin_type, "make-module-type", 0, &make_module_type_, a);
+  a = init_builtin (builtin_type, "module-printer", 1, &module_printer, a);
+  a = init_builtin (builtin_type, "module-variable", 2, &module_variable_, a);
+  a = init_builtin (builtin_type, "module-ref", 2, &module_ref_, a);
+  a = init_builtin (builtin_type, "module-define!", 3, &module_define_x, a);
+  /* src/posix.mes */
+  a = init_builtin (builtin_type, "peek-byte", 0, &peek_byte, a);
+  a = init_builtin (builtin_type, "read-byte", 0, &read_byte, a);
+  a = init_builtin (builtin_type, "unread-byte", 1, &unread_byte, a);
+  a = init_builtin (builtin_type, "peek-char", 0, &peek_char, a);
+  a = init_builtin (builtin_type, "read-char", -1, &read_char, a);
+  a = init_builtin (builtin_type, "unread-char", 1, &unread_char, a);
+  a = init_builtin (builtin_type, "write-char", -1, &write_char, a);
+  a = init_builtin (builtin_type, "write-byte", -1, &write_byte, a);
+  a = init_builtin (builtin_type, "getenv", 1, &getenv_, a);
+  a = init_builtin (builtin_type, "setenv", 2, &setenv_, a);
+  a = init_builtin (builtin_type, "access?", 2, &access_p, a);
+  a = init_builtin (builtin_type, "current-input-port", 0, &current_input_port, a);
+  a = init_builtin (builtin_type, "open-input-file", 1, &open_input_file, a);
+  a = init_builtin (builtin_type, "open-input-string", 1, &open_input_string, a);
+  a = init_builtin (builtin_type, "set-current-input-port", 1, &set_current_input_port, a);
+  a = init_builtin (builtin_type, "current-output-port", 0, &current_output_port, a);
+  a = init_builtin (builtin_type, "current-error-port", 0, &current_error_port, a);
+  a = init_builtin (builtin_type, "open-output-file", -1, &open_output_file, a);
+  a = init_builtin (builtin_type, "set-current-output-port", 1, &set_current_output_port, a);
+  a = init_builtin (builtin_type, "set-current-error-port", 1, &set_current_error_port, a);
+  a = init_builtin (builtin_type, "chmod", 2, &chmod_, a);
+  a = init_builtin (builtin_type, "isatty?", 1, &isatty_p, a);
+  a = init_builtin (builtin_type, "primitive-fork", 0, &primitive_fork, a);
+  a = init_builtin (builtin_type, "execl", 2, &execl_, a);
+  a = init_builtin (builtin_type, "core:waitpid", 2, &waitpid_, a);
+  a = init_builtin (builtin_type, "current-time", 0, &current_time, a);
+  a = init_builtin (builtin_type, "gettimeofday", 0, &gettimeofday_, a);
+  a = init_builtin (builtin_type, "get-internal-run-time", 0, &get_internal_run_time, a);
+  a = init_builtin (builtin_type, "getcwd", 0, &getcwd_, a);
+  a = init_builtin (builtin_type, "dup", 1, &dup_, a);
+  a = init_builtin (builtin_type, "dup2", 2, &dup2_, a);
+  a = init_builtin (builtin_type, "delete-file", 1, &delete_file, a);
+  /* src/reader.mes */
+  a = init_builtin (builtin_type, "core:read-input-file-env", 2, &read_input_file_env_, a);
+  a = init_builtin (builtin_type, "read-input-file-env", 1, &read_input_file_env, a);
+  a = init_builtin (builtin_type, "read-env", 1, &read_env, a);
+  a = init_builtin (builtin_type, "reader-read-sexp", 3, &reader_read_sexp, a);
+  a = init_builtin (builtin_type, "reader-read-character", 0, &reader_read_character, a);
+  a = init_builtin (builtin_type, "reader-read-binary", 0, &reader_read_binary, a);
+  a = init_builtin (builtin_type, "reader-read-octal", 0, &reader_read_octal, a);
+  a = init_builtin (builtin_type, "reader-read-hex", 0, &reader_read_hex, a);
+  a = init_builtin (builtin_type, "reader-read-string", 0, &reader_read_string, a);
+  /* src/strings.mes */
+  a = init_builtin (builtin_type, "string=?", 2, &string_equal_p_, a);
+  a = init_builtin (builtin_type, "symbol->string", 1, &symbol_to_string_, a);
+  a = init_builtin (builtin_type, "symbol->keyword", 1, &symbol_to_keyword_, a);
+  a = init_builtin (builtin_type, "keyword->string", 1, &keyword_to_string, a);
+  a = init_builtin (builtin_type, "string->symbol", 1, &string_to_symbol, a);
+  a = init_builtin (builtin_type, "make-symbol", 1, &make_symbol_, a);
+  a = init_builtin (builtin_type, "string->list", 1, &string_to_list, a);
+  a = init_builtin (builtin_type, "list->string", 1, &list_to_string, a);
+  a = init_builtin (builtin_type, "read-string", -1, &read_string, a);
+  a = init_builtin (builtin_type, "string-append", -1, &string_append, a);
+  a = init_builtin (builtin_type, "string-length", 1, &string_length, a);
+  a = init_builtin (builtin_type, "string-ref", 2, &string_ref, a);
+  /* src/struct.mes */
+  a = init_builtin (builtin_type, "make-struct", 3, &make_struct, a);
+  a = init_builtin (builtin_type, "struct-length", 1, &struct_length, a);
+  a = init_builtin (builtin_type, "struct-ref", 2, &struct_ref, a);
+  a = init_builtin (builtin_type, "struct-set!", 3, &struct_set_x, a);
+  /* src/vector.mes */
+  a = init_builtin (builtin_type, "core:make-vector", 1, &make_vector_, a);
+  a = init_builtin (builtin_type, "vector-length", 1, &vector_length, a);
+  a = init_builtin (builtin_type, "vector-ref", 2, &vector_ref, a);
+  a = init_builtin (builtin_type, "vector-set!", 3, &vector_set_x, a);
+  a = init_builtin (builtin_type, "list->vector", 1, &list_to_vector, a);
+  a = init_builtin (builtin_type, "vector->list", 1, &vector_to_list, a);
+  return a;
+}

src/eval.c

@@ -0,0 +1,809 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians
+ *
+ * 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 "mes/mes.h"
+
+struct scm *
+eval_apply ()
+{
+  struct scm *AA;
+  struct scm *ARGS;
+  struct scm *BODY;
+  struct scm *CL;
+  struct scm *ENTRY;
+  struct scm *EXPANDERS;
+  struct scm *FORMALS;
+  struct scm *INPUT;
+  struct scm *NAME;
+  struct scm *MACRO;
+  struct scm *P;
+  struct scm *PROGRAM;
+  struct scm *SC_EXPAND;
+  struct scm *V;
+  struct scm *X;
+  int global_p;
+  int macro_p;
+  int t;
+  struct scm *C;
+eval_apply:
+
+  if (R3 == cell_vm_evlis2)
+    {
+      goto evlis2;
+    }
+  else if (R3 == cell_vm_evlis3)
+    {
+      goto evlis3;
+    }
+  else if (R3 == cell_vm_eval_check_func)
+    {
+      goto eval_check_func;
+    }
+  else if (R3 == cell_vm_eval2)
+    {
+      goto eval2;
+    }
+  else if (R3 == cell_vm_apply2)
+    {
+      goto apply2;
+    }
+  else if (R3 == cell_vm_if_expr)
+    {
+      goto if_expr;
+    }
+  else if (R3 == cell_vm_begin_eval)
+    {
+      goto begin_eval;
+    }
+  else if (R3 == cell_vm_eval_set_x)
+    {
+      goto eval_set_x;
+    }
+  else if (R3 == cell_vm_macro_expand_car)
+    {
+      goto macro_expand_car;
+    }
+  else if (R3 == cell_vm_return)
+    {
+      goto vm_return;
+    }
+  else if (R3 == cell_vm_macro_expand_cdr)
+    {
+      goto macro_expand_cdr;
+    }
+  else if (R3 == cell_vm_eval_define)
+    {
+      goto eval_define;
+    }
+  else if (R3 == cell_vm_macro_expand)
+    {
+      goto macro_expand;
+    }
+  else if (R3 == cell_vm_macro_expand_lambda)
+    {
+      goto macro_expand_lambda;
+    }
+  else if (R3 == cell_vm_eval_pmatch_car)
+    {
+      goto eval_pmatch_car;
+    }
+  else if (R3 == cell_vm_begin_expand_macro)
+    {
+      goto begin_expand_macro;
+    }
+  else if (R3 == cell_vm_macro_expand_define)
+    {
+      goto macro_expand_define;
+    }
+  else if (R3 == cell_vm_begin_expand_eval)
+    {
+      goto begin_expand_eval;
+    }
+  else if (R3 == cell_vm_call_with_current_continuation2)
+    {
+      goto call_with_current_continuation2;
+    }
+  else if (R3 == cell_vm_macro_expand_set_x)
+    {
+      goto macro_expand_set_x;
+    }
+  else if (R3 == cell_vm_eval_pmatch_cdr)
+    {
+      goto eval_pmatch_cdr;
+    }
+  else if (R3 == cell_vm_macro_expand_define_macro)
+    {
+      goto macro_expand_define_macro;
+    }
+  else if (R3 == cell_vm_begin_primitive_load)
+    {
+      goto begin_primitive_load;
+    }
+  else if (R3 == cell_vm_evlis)
+    {
+      goto evlis;
+    }
+  else if (R3 == cell_vm_apply)
+    {
+      goto apply;
+    }
+  else if (R3 == cell_vm_eval)
+    {
+      goto eval;
+    }
+  else if (R3 == cell_vm_eval_macro_expand_eval)
+    {
+      goto eval_macro_expand_eval;
+    }
+  else if (R3 == cell_vm_eval_macro_expand_expand)
+    {
+      goto eval_macro_expand_expand;
+    }
+  else if (R3 == cell_vm_begin)
+    {
+      goto begin;
+    }
+  else if (R3 == cell_vm_begin_expand)
+    {
+      goto begin_expand;
+    }
+  else if (R3 == cell_vm_begin_expand_primitive_load)
+    {
+      goto begin_expand_primitive_load;
+    }
+  else if (R3 == cell_vm_if)
+    {
+      goto vm_if;
+    }
+  else if (R3 == cell_vm_call_with_values2)
+    {
+      goto call_with_values2;
+    }
+  else if (R3 == cell_unspecified)
+    {
+      return R1;
+    }
+  else
+    {
+      error (cell_symbol_system_error,
+             make_string ("eval/apply unknown continuation", string_len ("eval/apply unknown continuation")));
+    }
+
+evlis:
+
+  if (R1 == cell_nil)
+    {
+      goto vm_return;
+    }
+
+  if (R1->type != TPAIR)
+    {
+      goto eval;
+    }
+
+  push_cc (R1->car, R1, R0, cell_vm_evlis2);
+  goto eval;
+evlis2:
+  push_cc (R2->cdr, R1, R0, cell_vm_evlis3);
+  goto evlis;
+evlis3:
+  R1 = cons (R2, R1);
+  goto vm_return;
+apply:
+  g_stack_array[g_stack + FRAME_PROCEDURE] = R1->car;
+  t = R1->car->type;
+
+  if (t == TSTRUCT && builtin_p (R1->car) == cell_t)
+    {
+      check_formals (R1->car, builtin_arity (R1->car), R1->cdr);
+      R1 = apply_builtin (R1->car, R1->cdr);    /* FIXME: move into eval_apply */
+      goto vm_return;
+    }
+  else if (t == TCLOSURE)
+    {
+      CL = R1->car->cdr;
+      BODY = CL->cdr->cdr;
+      FORMALS = CL->cdr->car;
+      ARGS = R1->cdr;
+      AA = CL->car->cdr;
+      AA = AA->cdr;
+      check_formals (R1->car, FORMALS, R1->cdr);
+      P = pairlis (FORMALS, ARGS, AA);
+      call_lambda (BODY, P);
+      goto begin;
+    }
+  else if (t == TCONTINUATION)
+    {
+      V = R1->car->cdr;
+
+      if (V->length)
+        {
+          for (t = 0; t < V->length; t = t + 1)
+            {
+              g_stack_array[STACK_SIZE - V->length + t] = vector_ref_ (V, t);
+            }
+
+          g_stack = STACK_SIZE - V->length;
+        }
+
+      X = R1;
+      gc_pop_frame ();
+      R1 = X->cdr->car;
+      goto eval_apply;
+    }
+  else if (t == TSPECIAL)
+    {
+      C = R1->car;
+
+      if (C == cell_vm_apply)
+        {
+          push_cc (cons (R1->cdr->car, R1->cdr->cdr->car), R1, R0, cell_vm_return);
+          goto apply;
+        }
+      else if (C == cell_vm_eval)
+        {
+          push_cc (R1->cdr->car, R1, R1->cdr->cdr->car, cell_vm_return);
+          goto eval;
+        }
+      else if (C == cell_vm_begin_expand)
+        {
+          push_cc (cons (R1->cdr->car, cell_nil), R1, R1->cdr->cdr->car, cell_vm_return);
+          goto begin_expand;
+        }
+      else if (C == cell_call_with_current_continuation)
+        {
+          R1 = R1->cdr;
+          goto call_with_current_continuation;
+        }
+      else
+        {
+          check_apply (cell_f, R1->car);
+        }
+    }
+  else if (t == TSYMBOL)
+    {
+      if (R1->car == cell_symbol_call_with_values)
+        {
+          R1 = R1->cdr;
+          goto call_with_values;
+        }
+
+      if (R1->car == cell_symbol_current_module)
+        {
+          R1 = R0;
+          goto vm_return;
+        }
+
+      if (R1->car == cell_symbol_boot_module)
+        {
+          R1 = M0;
+          goto vm_return;
+        }
+    }
+  else if (t == TPAIR)
+    {
+      if (R1->car->car == cell_symbol_lambda)
+        {
+          FORMALS = R1->car->cdr->car;
+          ARGS = R1->cdr;
+          BODY = R1->car->cdr->cdr;
+          P = pairlis (FORMALS, R1->cdr, R0);
+          check_formals (R1, FORMALS, ARGS);
+          call_lambda (BODY, P);
+          goto begin;
+        }
+    }
+
+  /* write_error_ (R1->car); */
+  /* eputs ("\n"); */
+  push_cc (R1->car, R1, R0, cell_vm_apply2);
+  goto eval;
+apply2:
+  check_apply (R1, R2->car);
+  R1 = cons (R1, R2->cdr);
+  goto apply;
+eval:
+  t = R1->type;
+
+  if (t == TPAIR)
+    {
+      C = R1->car;
+
+      if (C == cell_symbol_pmatch_car)
+        {
+          push_cc (R1->cdr->car, R1, R0, cell_vm_eval_pmatch_car);
+          goto eval;
+        eval_pmatch_car:
+          X = R1;
+          gc_pop_frame ();
+          R1 = X->car;
+          goto eval_apply;
+        }
+      else if (C == cell_symbol_pmatch_cdr)
+        {
+          push_cc (R1->cdr->car, R1, R0, cell_vm_eval_pmatch_cdr);
+          goto eval;
+        eval_pmatch_cdr:
+          X = R1;
+          gc_pop_frame ();
+          R1 = X->cdr;
+          goto eval_apply;
+        }
+      else if (C == cell_symbol_quote)
+        {
+          X = R1;
+          gc_pop_frame ();
+          R1 = X->cdr->car;
+          goto eval_apply;
+        }
+      else if (C == cell_symbol_begin)
+        {
+          goto begin;
+        }
+      else if (C == cell_symbol_lambda)
+        {
+          R1 = make_closure_ (R1->cdr->car, R1->cdr->cdr, R0);
+          goto vm_return;
+        }
+      else if (C == cell_symbol_if)
+        {
+          R1 = R1->cdr;
+          goto vm_if;
+        }
+      else if (C == cell_symbol_set_x)
+        {
+          push_cc (R1->cdr->cdr->car, R1, R0, cell_vm_eval_set_x);
+          goto eval;
+        eval_set_x:
+          R1 = set_env_x (R2->cdr->car, R1, R0);
+          goto vm_return;
+        }
+      else if (C == cell_vm_macro_expand)
+        {
+          push_cc (R1->cdr->car, R1, R0, cell_vm_eval_macro_expand_eval);
+          goto eval;
+        eval_macro_expand_eval:
+          push_cc (R1, R2, R0, cell_vm_eval_macro_expand_expand);
+          goto macro_expand;
+        eval_macro_expand_expand:
+          goto vm_return;
+        }
+      else
+        {
+          if (R1->type == TPAIR && (R1->car == cell_symbol_define || R1->car == cell_symbol_define_macro))
+            {
+              global_p = R0->car->car != cell_closure;
+              macro_p = R1->car == cell_symbol_define_macro;
+
+              if (global_p)
+                {
+                  NAME = R1->cdr->car;
+
+                  if (R1->cdr->car->type == TPAIR)
+                    {
+                      NAME = NAME->car;
+                    }
+
+                  if (macro_p)
+                    {
+                      ENTRY = assq (NAME, g_macros);
+
+                      if (ENTRY == cell_f)
+                        {
+                          macro_set_x (NAME, cell_f);
+                        }
+                    }
+                  else
+                    {
+                      ENTRY = module_variable (R0, NAME);
+
+                      if (ENTRY == cell_f)
+                        {
+                          module_define_x (M0, NAME, cell_f);
+                        }
+                    }
+                }
+
+              R2 = R1;
+
+              if (R1->cdr->car->type != TPAIR)
+                {
+                  push_cc (R1->cdr->cdr->car, R2, cons (cons (R1->cdr->car, R1->cdr->car), R0),
+                           cell_vm_eval_define);
+                  goto eval;
+                }
+              else
+                {
+                  P = pairlis (R1->cdr->car, R1->cdr->car, R0);
+                  FORMALS = R1->cdr->car->cdr;
+                  BODY = R1->cdr->cdr;
+
+                  if (macro_p || global_p)
+                    {
+                      expand_variable (BODY, FORMALS);
+                    }
+
+                  R1 = cons (cell_symbol_lambda, cons (FORMALS, BODY));
+                  push_cc (R1, R2, P, cell_vm_eval_define);
+                  goto eval;
+                }
+
+            eval_define:
+              NAME = R2->cdr->car;
+
+              if (R2->cdr->car->type == TPAIR)
+                {
+                  NAME = NAME->car;
+                }
+
+              if (macro_p)
+                {
+                  ENTRY = macro_get_handle (NAME);
+                  R1 = make_tmacro (R1, NAME->cdr);
+                  set_cdr_x (ENTRY, R1);
+                }
+              else if (global_p)
+                {
+                  ENTRY = module_variable (R0, NAME);
+                  set_cdr_x (ENTRY, R1);
+                }
+              else
+                {
+                  ENTRY = cons (NAME, R1);
+                  AA = cons (ENTRY, cell_nil);
+                  set_cdr_x (AA, cdr (R0));
+                  set_cdr_x (R0, AA);
+                  CL = module_variable (R0, cell_closure);
+                  set_cdr_x (CL, AA);
+                }
+
+              R1 = cell_unspecified;
+              goto vm_return;
+            }
+
+          push_cc (R1->car, R1, R0, cell_vm_eval_check_func);
+          gc_check ();
+          goto eval;
+        eval_check_func:
+          push_cc (R2->cdr, R2, R0, cell_vm_eval2);
+          goto evlis;
+        eval2:
+          R1 = cons (R2->car, R1);
+          goto 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 */
+        {
+          R1 = cell_begin;
+          goto vm_return;
+        }
+
+      R1 = assert_defined (R1, module_ref (R0, R1));
+      goto vm_return;
+    }
+  else if (t == TVARIABLE)
+    {
+      R1 = R1->car->cdr;
+      goto vm_return;
+    }
+  else if (t == TBROKEN_HEART)
+    {
+      error (cell_symbol_system_error, R1);
+    }
+  else
+    {
+      goto vm_return;
+    }
+
+macro_expand:
+  if (R1->type != TPAIR || R1->car == cell_symbol_quote)
+    {
+      goto vm_return;
+    }
+
+  if (R1->car == cell_symbol_lambda)
+    {
+      push_cc (R1->cdr->cdr, R1, R0, cell_vm_macro_expand_lambda);
+      goto macro_expand;
+
+    macro_expand_lambda:
+      R2->cdr->cdr = R1;
+      R1 = R2;
+      goto vm_return;
+    }
+
+  if (R1->type == TPAIR && (MACRO = get_macro (R1->car)) != cell_f)
+    {
+      R1 = cons (MACRO, R1->cdr);
+      push_cc (R1, cell_nil, R0, cell_vm_macro_expand);
+      goto apply;
+    }
+
+  if (R1->car == cell_symbol_define || R1->car == cell_symbol_define_macro)
+    {
+      push_cc (R1->cdr->cdr, R1, R0, cell_vm_macro_expand_define);
+      goto macro_expand;
+
+    macro_expand_define:
+      R2->cdr->cdr = R1;
+      R1 = R2;
+
+      if (R1->car == cell_symbol_define_macro)
+        {
+          push_cc (R1, R1, R0, cell_vm_macro_expand_define_macro);
+          goto eval;
+
+        macro_expand_define_macro:
+          R1 = R2;
+        }
+
+      goto vm_return;
+    }
+
+  if (R1->car == cell_symbol_set_x)
+    {
+      push_cc (R1->cdr->cdr, R1, R0, cell_vm_macro_expand_set_x);
+      goto macro_expand;
+
+    macro_expand_set_x:
+      R2->cdr->cdr = R1;
+      R1 = R2;
+      goto vm_return;
+    }
+
+  if (R1->type == TPAIR && R1->car->type == TSYMBOL)
+    {
+      MACRO = macro_get_handle (cell_symbol_portable_macro_expand);
+      EXPANDERS = module_ref (R0, cell_symbol_sc_expander_alist);
+      if ((R1->car != cell_symbol_begin) && (MACRO != cell_f) && (EXPANDERS != cell_undefined))
+        {
+          MACRO = assq (R1->car, EXPANDERS);
+          if (MACRO != cell_f)
+            {
+              SC_EXPAND = module_ref (R0, cell_symbol_macro_expand);
+              R2 = R1;
+
+              if (SC_EXPAND != cell_undefined && SC_EXPAND != cell_f)
+                {
+                  R1 = cons (SC_EXPAND, cons (R1, cell_nil));
+                  goto apply;
+                }
+            }
+        }
+    }
+
+  push_cc (R1->car, R1, R0, cell_vm_macro_expand_car);
+  goto macro_expand;
+
+macro_expand_car:
+  R2->car = R1;
+  R1 = R2;
+
+  if (R1->cdr == cell_nil)
+    {
+      goto vm_return;
+    }
+
+  push_cc (R1->cdr, R1, R0, cell_vm_macro_expand_cdr);
+  goto macro_expand;
+
+macro_expand_cdr:
+  R2->cdr = R1;
+  R1 = R2;
+  goto vm_return;
+
+begin:
+  X = cell_unspecified;
+
+  while (R1 != cell_nil)
+    {
+      gc_check ();
+
+      if (R1->type == TPAIR)
+        {
+          if (R1->car->car == cell_symbol_primitive_load)
+            {
+              PROGRAM = cons (R1->car, cell_nil);
+              push_cc (PROGRAM, R1, R0, cell_vm_begin_primitive_load);
+              goto begin_expand;
+            begin_primitive_load:
+              R2->car = R1;
+              R1 = R2;
+            }
+        }
+
+      if (R1->type == TPAIR && R1->car->type == TPAIR)
+        {
+          if (R1->car->car == cell_symbol_begin)
+            {
+              R1 = append2 (R1->car->cdr, R1->cdr);
+            }
+        }
+
+      if (R1->cdr == cell_nil)
+        {
+          R1 = R1->car;
+          goto eval;
+        }
+
+      push_cc (R1->car, R1, R0, cell_vm_begin_eval);
+      goto eval;
+    begin_eval:
+      X = R1;
+      R1 = R2->cdr;
+    }
+
+  R1 = X;
+  goto vm_return;
+begin_expand:
+  X = cell_unspecified;
+
+  while (R1 != cell_nil)
+    {
+      gc_check ();
+
+      if (R1->type == TPAIR)
+        {
+          if (R1->car->type == TPAIR && R1->car->car == cell_symbol_begin)
+            {
+              R1 = append2 (R1->car->cdr, R1->cdr);
+            }
+
+          if (R1->car->car == cell_symbol_primitive_load)
+            {
+              push_cc (R1->car->cdr->car, R1, R0, cell_vm_begin_expand_primitive_load);
+              goto eval;        /* FIXME: expand too?! */
+            begin_expand_primitive_load:
+
+              if (R1->type == TNUMBER && R1->value == 0)
+                {
+                  R1->value = 0;        /* Not needed but haven't cleaned this block up yet */
+                }
+              else if (R1->type == TSTRING)
+                {
+                  INPUT = set_current_input_port (open_input_file (R1));
+                }
+              else if (R1->type == TPORT)
+                {
+                  INPUT = set_current_input_port (R1);
+                }
+              else
+                {
+                  require (FALSE, "Error in src/eval.c: begin_expand_primitive_load");
+                }
+
+              push_cc (INPUT, R2, R0, cell_vm_return);
+              X = read_input_file_env ();
+
+              if (g_debug > 4)
+                {
+                  module_printer (M0);
+                }
+
+              gc_pop_frame ();
+              INPUT = R1;
+              R1 = X;
+              set_current_input_port (INPUT);
+              R1 = cons (cell_symbol_begin, R1);
+              R2->car = R1;
+              R1 = R2;
+              continue;
+            }
+        }
+
+      push_cc (R1->car, R1, R0, cell_vm_begin_expand_macro);
+      goto macro_expand;
+    begin_expand_macro:
+
+      if (R1 != R2->car)
+        {
+          R2->car = R1;
+          R1 = R2;
+          continue;
+        }
+
+      R1 = R2;
+      expand_variable (R1->car, cell_nil);
+      push_cc (R1->car, R1, R0, cell_vm_begin_expand_eval);
+      goto eval;
+    begin_expand_eval:
+      X = R1;
+      R1 = R2->cdr;
+    }
+
+  R1 = X;
+  goto vm_return;
+vm_if:
+  push_cc (R1->car, R1, R0, cell_vm_if_expr);
+  goto eval;
+if_expr:
+  X = R1;
+  R1 = R2;
+
+  if (X != cell_f)
+    {
+      R1 = R1->cdr->car;
+      goto eval;
+    }
+
+  if (R1->cdr->cdr != cell_nil)
+    {
+      R1 = R1->cdr->cdr->car;
+      goto eval;
+    }
+
+  R1 = cell_unspecified;
+  goto vm_return;
+call_with_current_continuation:
+  gc_push_frame ();
+  X = make_tcontinuation (g_continuations, g_stack);
+  g_continuations = g_continuations + 1;
+  V = make_vector__ (5);
+
+  for (t = 0; t < 5; t = t + 1)
+    {
+      vector_set_x_ (V, t, g_stack_array[g_stack + t]);
+    }
+
+  X->continuation = V;
+  gc_pop_frame ();
+  push_cc (cons (R1->car, cons (X, cell_nil)), X, R0, cell_vm_call_with_current_continuation2);
+  goto apply;
+call_with_current_continuation2:
+  V = make_vector__ (5);
+
+  for (t = 0; t < 5; t = t + 1)
+    {
+      vector_set_x_ (V, t, g_stack_array[g_stack + t]);
+    }
+
+  R2->continuation = V;
+  goto vm_return;
+call_with_values:
+  push_cc (cons (R1->car, cell_nil), R1, R0, cell_vm_call_with_values2);
+  goto apply;
+call_with_values2:
+
+  if (R1->type == TVALUES)
+    {
+      R1 = R1->cdr;
+    }
+
+  R1 = cons (R2->cdr->car, R1);
+  goto apply;
+vm_return:
+  X = R1;
+  gc_pop_frame ();
+  R1 = X;
+  goto eval_apply;
+}

src/gc.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians
  *
  * This file is part of GNU Mes.
  *
@@ -21,326 +22,332 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
+SCM GC_SAFETY;
+SCM ARENA_SIZE;
+SCM MAX_ARENA_SIZE;
+SCM JAM_SIZE;
+// CONSTANT FRAME_SIZE 5
+#define FRAME_SIZE 5
+
 #include <assert.h>
 #include <errno.h>
 #include <string.h>
 #include <stdlib.h>
 
-long ARENA_SIZE;
-long MAX_ARENA_SIZE;
-long STACK_SIZE;
-long JAM_SIZE;
-long GC_SAFETY;
-long MAX_STRING;
-char *g_arena;
-long g_free;
-SCM g_stack;
-SCM *g_stack_array;
-struct scm *g_cells;
 struct scm *g_news;
 
-SCM
-gc_init ()                ///((internal))
+void
+initialize_memory ()
 {
-#if SYSTEM_LIBC
-  ARENA_SIZE = 100000000;    // 2.3GiB
-#else
-  ARENA_SIZE = 300000;       // 32b: 3MiB, 64b: 6 MiB
-#endif
-  MAX_ARENA_SIZE = 100000000;
-  STACK_SIZE = 20000;
-
-  JAM_SIZE = 20000;
-  GC_SAFETY = 2000;
-  MAX_STRING = 524288;
-
-  char *p;
-  if (p = getenv ("MES_MAX_ARENA"))
-    MAX_ARENA_SIZE = atoi (p);
-  if (p = getenv ("MES_ARENA"))
-    ARENA_SIZE = atoi (p);
-  JAM_SIZE = ARENA_SIZE / 10;
-  if (p = getenv ("MES_JAM"))
-    JAM_SIZE = atoi (p);
-  GC_SAFETY = ARENA_SIZE / 100;
-  if (p = getenv ("MES_SAFETY"))
-    GC_SAFETY = atoi (p);
-  if (p = getenv ("MES_STACK"))
-    STACK_SIZE = atoi (p);
-  if (p = getenv ("MES_MAX_STRING"))
-    MAX_STRING = atoi (p);
-
-  long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
-  void *a = malloc (arena_bytes + STACK_SIZE * sizeof (SCM));
-  g_cells = (struct scm *) a;
-  g_stack_array = (SCM *) (a + arena_bytes);
-
-  TYPE (0) = TVECTOR;
-  LENGTH (0) = 1000;
-  VECTOR (0) = 0;
-  g_cells++;
-  TYPE (0) = TCHAR;
-  VALUE (0) = 'c';
-
-  // FIXME: remove MES_MAX_STRING, grow dynamically
-  g_buf = (char *) malloc (MAX_STRING);
-
-  return 0;
-}
-
-SCM
-gc_init_news ()                 ///((internal))
-{
-  g_news = g_cells + g_free;
-  NTYPE (0) = TVECTOR;
-  NLENGTH (0) = 1000;
-  NVECTOR (0) = 0;
-  g_news++;
-  NTYPE (0) = TCHAR;
-  NVALUE (0) = 'n';
-  return 0;
-}
-
-SCM
-gc_up_arena ()                  ///((internal))
-{
-  long old_arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
-  if (ARENA_SIZE >> 1 < MAX_ARENA_SIZE >> 2)
-    {
-      ARENA_SIZE <<= 1;
-      JAM_SIZE <<= 1;
-      GC_SAFETY <<= 1;
-    }
-  else
-    ARENA_SIZE = MAX_ARENA_SIZE - JAM_SIZE;
-  long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
-  void *p = realloc (g_cells - 1, arena_bytes + STACK_SIZE * sizeof (SCM));
-  if (!p)
-    {
-      eputs ("realloc failed, g_free=");
-      eputs (itoa (g_free));
-      eputs (":");
-      eputs (itoa (ARENA_SIZE - g_free));
-      eputs ("\n");
-      assert (0);
-      exit (1);
-    }
-  g_cells = (struct scm *) p;
-  memcpy (p + arena_bytes, p + old_arena_bytes, STACK_SIZE * sizeof (SCM));
-  g_cells++;
-
-  return 0;
+  g_news = 0;
+  MAX_ARENA_SIZE = get_env_value ("MES_MAX_ARENA", 100000000);
+  ARENA_SIZE = get_env_value ("MES_ARENA", 10000000);
+  JAM_SIZE = get_env_value ("MES_JAM", ARENA_SIZE / 10);
+  GC_SAFETY = get_env_value ("MES_SAFETY", ARENA_SIZE / 100);
+  STACK_SIZE = get_env_value ("MES_STACK", 20000);
+  MAX_STRING = get_env_value ("MES_MAX_STRING", 524288);
 }
 
 void
-gc_flip ()                      ///((internal))
+gc_init_cells ()                /* ((internal)) */
 {
-  if (g_debug > 2)
-    {
-      eputs (";;;   => jam[");
-      eputs (itoa (g_free));
-      eputs ("]\n");
-    }
-  if (g_free > JAM_SIZE)
-    JAM_SIZE = g_free + g_free / 2;
-  memcpy (g_cells - 1, g_news - 1, (g_free + 2) * sizeof (struct scm));
+  SCM stack_size = ((ARENA_SIZE + JAM_SIZE) * sizeof (struct scm)) + (STACK_SIZE * sizeof (SCM));
+  g_stack_array = malloc (stack_size);
+  g_buf = malloc (MAX_STRING);
 }
 
-SCM
-gc_copy (SCM old)               ///((internal))
+struct scm *make_char (SCM c);
+struct scm *
+mes_g_stack (struct scm *a)     /* ((internal)) */
 {
-  if (TYPE (old) == TBROKEN_HEART)
-    return g_cells[old].car;
-  SCM new = g_free++;
-  g_news[new] = g_cells[old];
-  if (NTYPE (new) == TSTRUCT || NTYPE (new) == TVECTOR)
-    {
-      NVECTOR (new) = g_free;
-      for (long i = 0; i < LENGTH (old); i++)
-        g_news[g_free++] = g_cells[VECTOR (old) + i];
-    }
-  else if (NTYPE (new) == TBYTES)
-    {
-      char const *src = CBYTES (old);
-      char *dest = NCBYTES (new);
-      size_t length = NLENGTH (new);
-      memcpy (dest, src, length + 1);
-      g_free += bytes_cells (length) - 1;
+  g_stack = STACK_SIZE;
+  R0 = a;
+  R1 = make_char (0);
+  R2 = make_char (0);
+  R3 = make_char (0);
+  return R0;
+}
 
-      if (g_debug > 4)
+struct scm *
+make_frame (SCM index)
+{
+  SCM array_index = (STACK_SIZE - (index * FRAME_SIZE));
+  struct scm *procedure = g_stack_array[array_index + FRAME_PROCEDURE];
+
+  if (!procedure)
+    {
+      procedure = cell_f;
+    }
+
+  return make_struct (make_frame_type (), cons (cell_symbol_frame, cons (procedure, cell_nil)),
+                      cstring_to_symbol ("frame-printer"));
+}
+
+struct scm *
+make_stack ()                   /* ((arity . n)) */
+{
+  struct scm *stack_type = make_stack_type ();
+  SCM size = (STACK_SIZE - g_stack) / FRAME_SIZE;
+  struct scm *frames = make_vector__ (size);
+  SCM i;
+
+  for (i = 0; i < size; i = i + 1)
+    {
+      struct scm *frame = make_frame (i);
+      vector_set_x_ (frames, i, frame);
+    }
+
+  struct scm *values = cell_nil;
+  values = cons (frames, values);
+  values = cons (cell_symbol_stack, values);
+  return make_struct (stack_type, values, cell_unspecified);
+}
+
+
+struct scm *
+make_cell (struct scm *type, struct scm *car, struct scm *cdr)
+{
+  require (type->type == TNUMBER, "type does not match TNUMBER in src/gc.c: make_cell\n");
+
+  if (type->value == TCHAR || type->value == TNUMBER)
+    {
+      if (0 != car)
         {
-          eputs ("gc copy bytes: ");
-          eputs (src);
-          eputs ("\n");
-          eputs ("    length: ");
-          eputs (itoa (LENGTH (old)));
-          eputs ("\n");
-          eputs ("    nlength: ");
-          eputs (itoa (NLENGTH (new)));
-          eputs ("\n");
-          eputs ("        ==> ");
-          eputs (dest);
-          eputs ("\n");
+          car = car->car;
+        }
+
+      if (0 != cdr)
+        {
+          cdr = cdr->cdr;
         }
     }
-  TYPE (old) = TBROKEN_HEART;
-  CAR (old) = new;
-  return new;
-}
 
-SCM
-gc_relocate_car (SCM new, SCM car)      ///((internal))
-{
-  g_news[new].car = car;
-  return cell_unspecified;
-}
-
-SCM
-gc_relocate_cdr (SCM new, SCM cdr)      ///((internal))
-{
-  g_news[new].cdr = cdr;
-  return cell_unspecified;
-}
-
-void
-gc_loop (SCM scan)              ///((internal))
-{
-  SCM car;
-  SCM cdr;
-  while (scan < g_free)
-    {
-      if (NTYPE (scan) == TBROKEN_HEART)
-        error (cell_symbol_system_error, cstring_to_symbol ("gc"));
-      if (NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR || NTYPE (scan) == TREF || scan == 1  // null
-          || NTYPE (scan) == TVARIABLE)
-        {
-          car = gc_copy (g_news[scan].car);
-          gc_relocate_car (scan, car);
-        }
-      if ((NTYPE (scan) == TCLOSURE || NTYPE (scan) == TCONTINUATION || NTYPE (scan) == TKEYWORD || NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR || NTYPE (scan) == TPORT || NTYPE (scan) == TSPECIAL || NTYPE (scan) == TSTRING || NTYPE (scan) == TSYMBOL || scan == 1     // null
-           || NTYPE (scan) == TVALUES) && g_news[scan].cdr)     // allow for 0 terminated list of symbols
-        {
-          cdr = gc_copy (g_news[scan].cdr);
-          gc_relocate_cdr (scan, cdr);
-        }
-      if (NTYPE (scan) == TBYTES)
-        scan += bytes_cells (NLENGTH (scan)) - 1;
-      scan++;
-    }
-  gc_flip ();
-}
-
-SCM
-gc_check ()
-{
-  if (g_free + GC_SAFETY > ARENA_SIZE)
-    gc ();
-  return cell_unspecified;
-}
-
-SCM
-gc_ ()                          ///((internal))
-{
-  gc_init_news ();
-  if (g_debug == 2)
-    eputs (".");
-  if (g_debug > 2)
-    {
-      eputs (";;; gc[");
-      eputs (itoa (g_free));
-      eputs (":");
-      eputs (itoa (ARENA_SIZE - g_free));
-      eputs ("]...");
-    }
-  g_free = 1;
-
-#if __MESC__
-  if (ARENA_SIZE < MAX_ARENA_SIZE && (long) g_news > 0)
-#else
-  if (ARENA_SIZE < MAX_ARENA_SIZE && g_news > 0)
-#endif
-    {
-      if (g_debug == 2)
-        eputs ("+");
-      if (g_debug > 2)
-        {
-          eputs (" up[");
-          eputs (itoa ((unsigned long) g_cells));
-          eputs (",");
-          eputs (itoa ((unsigned long) g_news));
-          eputs (":");
-          eputs (itoa (ARENA_SIZE));
-          eputs (",");
-          eputs (itoa (MAX_ARENA_SIZE));
-          eputs ("]...");
-        }
-      gc_up_arena ();
-    }
-
-  for (long i = g_free; i < g_symbol_max; i++)
-    gc_copy (i);
-  g_symbols = gc_copy (g_symbols);
-  g_macros = gc_copy (g_macros);
-  g_ports = gc_copy (g_ports);
-  m0 = gc_copy (m0);
-  for (long i = g_stack; i < STACK_SIZE; i++)
-    g_stack_array[i] = gc_copy (g_stack_array[i]);
-  gc_loop (1);
-}
-
-SCM
-gc ()
-{
-  if (g_debug > 5)
-    {
-      eputs ("symbols: ");
-      write_error_ (g_symbols);
-      eputs ("\n");
-      eputs ("R0: ");
-      write_error_ (r0);
-      eputs ("\n");
-    }
-  gc_push_frame ();
-  gc_ ();
-  gc_pop_frame ();
-  if (g_debug > 5)
-    {
-      eputs ("symbols: ");
-      write_error_ (g_symbols);
-      eputs ("\n");
-      eputs ("R0: ");
-      write_error_ (r0);
-      eputs ("\n");
-    }
-}
-
-SCM
-gc_push_frame ()                ///((internal))
-{
-  if (g_stack < 5)
-    assert (!"STACK FULL");
-  g_stack_array[--g_stack] = cell_f;
-  g_stack_array[--g_stack] = r0;
-  g_stack_array[--g_stack] = r1;
-  g_stack_array[--g_stack] = r2;
-  g_stack_array[--g_stack] = r3;
-  return g_stack;
-}
-
-SCM
-gc_peek_frame ()                ///((internal))
-{
-  r3 = g_stack_array[g_stack];
-  r2 = g_stack_array[g_stack + 1];
-  r1 = g_stack_array[g_stack + 2];
-  r0 = g_stack_array[g_stack + 3];
-  return g_stack_array[g_stack + FRAME_PROCEDURE];
-}
-
-SCM
-gc_pop_frame ()                 ///((internal))
-{
-  SCM x = gc_peek_frame ();
-  g_stack += 5;
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = type->value;
+  x->car = car;
+  x->cdr = cdr;
+  return x;
+}
+
+
+struct scm *
+make_bytes (char *s, SCM length)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TBYTES;
+  x->length = length;
+  x->string = malloc (length + 1);
+  char *p = x->string;
+
+  if (0 != length)
+    {
+      block_copy (s, p, length + 1);
+    }
+
+  return x;
+}
+
+struct scm *
+make_tref (struct scm *y)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TREF;
+  x->car = y;
+  x->cdr = 0;
+  return x;
+}
+
+struct scm *
+make_vector__ (SCM k)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  struct scm *v = malloc (k * sizeof (struct scm));
+  x->type = TVECTOR;
+  x->length = k;
+  x->cdr = v;
+
+  for (k = k - 1; k >= 0; k = k - 1)
+    {
+      v->type = TREF;
+      v->car = cell_unspecified;
+      v->cdr = 0;
+      v = v + CELL_SIZE;
+    }
+
+  return x;
+}
+
+struct scm *
+make_struct (struct scm *type, struct scm *fields, struct scm *printer)
+{
+  SCM size = 2 + length__ (fields);
+  struct scm *v = malloc (size * sizeof (struct scm));
+  struct scm *w = v + 1;
+  struct scm *entry = vector_entry (type);
+  struct scm *print = vector_entry (printer);
+
+  v->type = entry->type;
+  v->car = entry->car;
+  v->cdr = entry->cdr;
+
+  w->type = print->type;
+  w->car = print->car;
+  w->cdr = print->cdr;
+
+  SCM i;
+  for (i = 2; i < size; i = i + 1)
+    {
+      struct scm *e = cell_unspecified;
+
+      if (fields != cell_nil)
+        {
+          e = fields->car;
+          fields = fields->cdr;
+        }
+
+      entry = vector_entry (e);
+      w = v + i;
+
+      w->type = entry->type;
+      w->car = entry->car;
+      w->cdr = entry->cdr;
+    }
+
+  struct scm *r = malloc (sizeof (struct scm));
+  r->type = TSTRUCT;
+  r->length = size;
+  r->cdr = v;
+  return r;
+}
+
+struct scm *
+gc_check ()
+{
+  return cell_unspecified;
+}
+
+struct scm *
+gc ()
+{
+  return cell_unspecified;
+}
+
+struct scm *
+make_tstring1 (SCM n)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TSTRING;
+  x->length = n;
+  x->cdr = 0;
+  return x;
+}
+
+struct scm *
+make_tstring2 (struct scm *a, struct scm *b)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TSTRING;
+  x->car = a;
+  x->cdr = b;
+  return x;
+}
+
+struct scm *
+make_keyword (struct scm *a, struct scm *b)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TKEYWORD;
+  x->car = a;
+  x->cdr = b;
+  return x;
+}
+
+struct scm *
+make_tsymbol (struct scm *a, struct scm *b)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TSYMBOL;
+  x->car = a;
+  x->cdr = b;
+  return x;
+}
+
+struct scm *
+make_port (SCM n, struct scm *s)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TPORT;
+  x->port = n;
+  x->cdr = s;
+  return x;
+}
+
+struct scm *
+make_char (SCM c)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TCHAR;
+  x->car = 0;
+  x->value = c;
+  return x;
+}
+
+struct scm *
+make_number (SCM n)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TNUMBER;
+  x->car = 0;
+  x->value = n;
+  return x;
+}
+
+struct scm *
+make_tmacro (struct scm *a, struct scm *b)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TMACRO;
+  x->car = a;
+  x->cdr = b;
+  return x;
+}
+
+struct scm *
+make_tcontinuation (SCM a, SCM b)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TCONTINUATION;
+  x->length = a;
+  x->value = b;
+  return x;
+}
+
+struct scm *
+make_tpair (struct scm *a, struct scm *b)
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TPAIR;
+  x->car = a;
+  x->cdr = b;
+  return x;
+}
+
+struct scm *
+make_closure_ (struct scm *args, struct scm *body, struct scm *a)       /* ((internal)) */
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TCLOSURE;
+  x->car = cell_f;
+  x->cdr = cons (cons (cell_circular, a), cons (args, body));
+  return x;
+}
+
+struct scm *
+make_variable_ (struct scm *var)        /* ((internal)) */
+{
+  struct scm *x = malloc (sizeof (struct scm));
+  x->type = TVARIABLE;
+  x->car = var;
+  x->cdr = 0;
   return x;
 }

src/hash.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,192 +22,155 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
-#include <assert.h>
 #include <string.h>
 
-int
-hash_cstring (char const *s, long size)
+SCM
+hash_cstring (char *s, SCM size)
 {
-  int hash = s[0] * 37;
+  int h = s[0] * 37;
+
   if (s[0] && s[1])
-    hash = hash + s[1] * 43;
-  assert (size);
-  hash = hash % size;
-  return hash;
+    {
+      h = h + s[1] * 43;
+    }
+
+  require (0 != size, "src/hash.c: hash_cstring must not be zero");
+  h = h % size;
+  return h;
 }
 
-int
-hashq_ (SCM x, long size)
+SCM
+hashq_ (struct scm *x, SCM size)
 {
-  if (TYPE (x) == TSPECIAL || TYPE (x) == TSYMBOL)
-    return hash_cstring (CSTRING (x), size);    // FIXME: hash x directly
-  error (cell_symbol_system_error, cons (MAKE_STRING0 ("hashq_: not a symbol"), x));
+  struct scm *y = x;
+  if (y->type == TSPECIAL || y->type == TSYMBOL)
+    {
+      char *p = y->cdr->string;
+      return hash_cstring (p, size);    /* FIXME: hash x directly */
+    }
+
+  error (cell_symbol_system_error, cons (make_string_ ("hashq_: not a symbol"), x));
+  exit (EXIT_FAILURE);
 }
 
-int
-hash_ (SCM x, long size)
+SCM
+hash_ (struct scm *x, SCM size)
 {
-  if (TYPE (x) == TSTRING)
-    return hash_cstring (CSTRING (x), size);
-  assert (0);
+  struct scm *y = x;
+  if (y->type == TSTRING)
+    {
+      char *p = y->cdr->string;
+      return hash_cstring (p, size);
+    }
+
+  require (FALSE, "src/hash.c: hash_ impossible condition hit");
   return hashq_ (x, size);
 }
 
-SCM
-hashq (SCM x, SCM size)
+struct scm *
+hashq (struct scm *x, struct scm *size)
 {
-  assert (0);
-  return MAKE_NUMBER (hashq_ (x, VALUE (size)));
+  require (FALSE, "src/hash.c: hashq impossible condition hit");
+  return make_number (hashq_ (x, size->value));
 }
 
-SCM
-hash (SCM x, SCM size)
+struct scm *
+hash (struct scm *x, struct scm *size)
 {
-  assert (0);
-  return MAKE_NUMBER (hash_ (x, VALUE (size)));
+  require (FALSE, "src/hash.c: hash impossible condition hit");
+  return make_number (hash_ (x, size->value));
 }
 
-SCM
-hashq_get_handle (SCM table, SCM key, SCM dflt)
+struct scm *
+hashq_get_handle (struct scm *table, struct scm *key, struct scm *dflt)
 {
-  long size = VALUE (struct_ref_ (table, 3));
-  unsigned hash = hashq_ (key, size);
-  SCM buckets = struct_ref_ (table, 4);
-  SCM bucket = vector_ref_ (buckets, hash);
-  SCM x = cell_f;
-  if (TYPE (dflt) == TPAIR)
-    x = CAR (dflt);
-  if (TYPE (bucket) == TPAIR)
-    x = assq (key, bucket);
-  return x;
-}
-
-SCM
-hashq_ref (SCM table, SCM key, SCM dflt)
-{
-#if defined (INLINE)
-  SCM x = hashq_get_handle (table, key, dflt);
-#else
-  long size = VALUE (struct_ref_ (table, 3));
-  unsigned hash = hashq_ (key, size);
-  SCM buckets = struct_ref_ (table, 4);
-  SCM bucket = vector_ref_ (buckets, hash);
-  SCM x = cell_f;
-  if (TYPE (dflt) == TPAIR)
-    x = CAR (dflt);
-  if (TYPE (bucket) == TPAIR)
-    x = assq (key, bucket);
-#endif
-  if (x != cell_f)
-    x = CDR (x);
-  return x;
-}
-
-SCM
-hash_ref (SCM table, SCM key, SCM dflt)
-{
-  long size = VALUE (struct_ref_ (table, 3));
-  unsigned hash = hash_ (key, size);
-  SCM buckets = struct_ref_ (table, 4);
-  SCM bucket = vector_ref_ (buckets, hash);
-  SCM x = cell_f;
-  if (TYPE (dflt) == TPAIR)
-    x = CAR (dflt);
-  if (TYPE (bucket) == TPAIR)
+  struct scm *ydflt = dflt;
+  if (ydflt->type == TPAIR)
     {
-      x = assoc (key, bucket);
-      if (x != cell_f)
-        x = CDR (x);
+      return ydflt->car;
     }
-  return x;
-}
 
-#if defined (INLINE)
-#error INLINE
-SCM
-hash_set_x_ (SCM table, unsigned hash, SCM key, SCM value)
-{
-  SCM buckets = struct_ref_ (table, 4);
-  SCM bucket = vector_ref_ (buckets, hash);
-  if (TYPE (bucket) != TPAIR)
-    bucket = cell_nil;
-  bucket = acons (key, value, bucket);
-  vector_set_x_ (buckets, hash, bucket);
-  return value;
-}
-#endif
-
-SCM
-hashq_set_x (SCM table, SCM key, SCM value)
-{
-  long size = VALUE (struct_ref_ (table, 3));
-  unsigned hash = hashq_ (key, size);
-#if defined (INLINE)
-  return hash_set_x_ (table, hash, key, value);
-#else
-  SCM buckets = struct_ref_ (table, 4);
-  SCM bucket = vector_ref_ (buckets, hash);
-  if (TYPE (bucket) != TPAIR)
-    bucket = cell_nil;
-  bucket = acons (key, value, bucket);
-  vector_set_x_ (buckets, hash, bucket);
-  return value;
-#endif
-}
-
-SCM
-hash_set_x (SCM table, SCM key, SCM value)
-{
-  long size = VALUE (struct_ref_ (table, 3));
-  unsigned hash = hash_ (key, size);
-#if defined (INLINE)
-  return hash_set_x_ (table, hash, key, value);
-#else
-  SCM buckets = struct_ref_ (table, 4);
-  SCM bucket = vector_ref_ (buckets, hash);
-  if (TYPE (bucket) != TPAIR)
-    bucket = cell_nil;
-  bucket = acons (key, value, bucket);
-  vector_set_x_ (buckets, hash, bucket);
-  return value;
-#endif
-}
-
-SCM
-hash_table_printer (SCM table)
-{
-  fdputs ("#<", __stdout);
-  display_ (struct_ref_ (table, 2));
-  fdputc (' ', __stdout);
-  fdputs ("size: ", __stdout);
-  display_ (struct_ref_ (table, 3));
-  fdputc (' ', __stdout);
-  SCM buckets = struct_ref_ (table, 4);
-  fdputs ("buckets: ", __stdout);
-  for (int i = 0; i < LENGTH (buckets); i++)
+  struct scm *ybucket = vector_ref_ (struct_ref_ (table, 4), hashq_ (key, struct_ref_ (table, 3)->value));
+  if (ybucket->type == TPAIR)
     {
-      SCM e = vector_ref_ (buckets, i);
-      if (e != cell_unspecified)
+      return assq (key, ybucket);
+    }
+
+  return cell_f;
+}
+
+struct scm *
+hashq_ref (struct scm *table, struct scm *key, struct scm *dflt)
+{
+  struct scm *x = hashq_get_handle (table, key, dflt);
+
+  if (x == cell_f)
+    {
+      return x;
+    }
+
+  return x->cdr;
+}
+
+struct scm *
+hash_ref (struct scm *table, struct scm *key, struct scm *dflt) /* External */
+{
+  struct scm *bucket = vector_ref_ (struct_ref_ (table, 4), hash_ (key, struct_ref_ (table, 3)->value));
+  if (bucket->type == TPAIR)
+    {
+      struct scm *y = assoc (key, bucket);
+      if (y != cell_f)
         {
-          fdputc ('[', __stdout);
-          while (TYPE (e) == TPAIR)
-            {
-              write_ (CAAR (e));
-              e = CDR (e);
-              if (TYPE (e) == TPAIR)
-                fdputc (' ', __stdout);
-            }
-          fdputs ("]\n  ", __stdout);
+          return y->cdr;
         }
     }
-  fdputc ('>', __stdout);
+
+  return cell_f;
 }
 
-SCM
-make_hashq_type ()              ///((internal))
+struct scm *
+hashq_set_x (struct scm *table, struct scm *key, struct scm *value)
 {
-  SCM record_type = cell_symbol_record_type;    // FIXME
-  SCM fields = cell_nil;
+  SCM size = struct_ref_ (table, 3)->value;
+  struct scm *buckets = struct_ref_ (table, 4);
+
+  struct scm *ybucket = vector_ref_ (buckets, hashq_ (key, size));
+  if (ybucket->type != TPAIR)
+    {
+      vector_set_x_ (buckets, hashq_ (key, size), acons (key, value, cell_nil));
+    }
+  else
+    {
+      vector_set_x_ (buckets, hashq_ (key, size),
+                     acons (key, value, vector_ref_ (buckets, hashq_ (key, size))));
+    }
+  return value;
+}
+
+struct scm *
+hash_set_x (struct scm *table, struct scm *key, struct scm *value)
+{
+  SCM size = struct_ref_ (table, 3)->value;
+  unsigned h = hash_ (key, size);
+  struct scm *buckets = struct_ref_ (table, 4);
+  struct scm *bucket = vector_ref_ (buckets, h);
+
+  struct scm *ybucket = bucket;
+  if (ybucket->type != TPAIR)
+    {
+      bucket = cell_nil;
+    }
+
+  bucket = acons (key, value, bucket);
+  vector_set_x_ (buckets, h, bucket);
+  return value;
+}
+
+struct scm *
+make_hashq_type ()              /* ((internal)) */
+{
+  struct scm *record_type = cell_symbol_record_type;    /* FIXME */
+  struct scm *fields = cell_nil;
   fields = cons (cell_symbol_buckets, fields);
   fields = cons (cell_symbol_size, fields);
   fields = cons (fields, cell_nil);
@@ -214,30 +178,49 @@ make_hashq_type ()              ///((internal))
   return make_struct (record_type, fields, cell_unspecified);
 }
 
-SCM
-make_hash_table_ (long size)
+struct scm *
+make_hash_table_ (SCM size)
 {
   if (!size)
-    size = 100;
-  SCM hashq_type = make_hashq_type ();
+    {
+      size = 100;
+    }
 
-  SCM buckets = make_vector__ (size);
-  SCM values = cell_nil;
+  struct scm *hashq_type = make_hashq_type ();
+  struct scm *buckets = make_vector__ (size);
+  struct scm *values = cell_nil;
   values = cons (buckets, values);
-  values = cons (MAKE_NUMBER (size), values);
+  values = cons (make_number (size), values);
   values = cons (cell_symbol_hashq_table, values);
-  //FIXME: symbol/printer return make_struct (hashq_type, values, cstring_to_symbol ("hash-table-printer");
+  /* FIXME: symbol/printer return make_struct (hashq_type, values, cstring_to_symbol ("hash-table-printer"); */
   return make_struct (hashq_type, values, cell_unspecified);
 }
 
-SCM
-make_hash_table (SCM x)
+struct scm *
+make_hash_table (struct scm *x)
 {
-  long size = 0;
-  if (TYPE (x) == TPAIR)
+  SCM size = 0;
+
+  struct scm *y = x;
+  if (y->type == TPAIR)
     {
-      assert (TYPE (x) == TNUMBER);
-      size = VALUE (x);
+      require (TNUMBER == y->type, "y->type must be TNUMBER\nsrc/hash.c: make_hash_table\n");
+      size = y->value;
     }
+
   return make_hash_table_ (size);
 }
+
+
+/* Externally exposed */
+struct scm *
+hashq_set_x_ (struct scm *table, struct scm *key, struct scm *value)
+{
+  return hashq_set_x (table, key, value);
+}
+
+struct scm *
+hash_ref_ (struct scm *table, struct scm *key, struct scm *dflt)
+{
+  return hash_ref (table, key, dflt);
+}

src/init.c

@@ -0,0 +1,144 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians
+ *
+ * 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 "mes/mes.h"
+void
+initialize_constants ()
+{
+  cell_nil = malloc (sizeof (struct scm));
+  cell_f = malloc (sizeof (struct scm));
+  cell_t = malloc (sizeof (struct scm));
+  cell_dot = malloc (sizeof (struct scm));
+  cell_arrow = malloc (sizeof (struct scm));
+  cell_undefined = malloc (sizeof (struct scm));
+  cell_unspecified = malloc (sizeof (struct scm));
+  cell_closure = malloc (sizeof (struct scm));
+  cell_circular = malloc (sizeof (struct scm));
+  cell_begin = malloc (sizeof (struct scm));
+  cell_call_with_current_continuation = malloc (sizeof (struct scm));
+  cell_vm_apply = malloc (sizeof (struct scm));
+  cell_vm_apply2 = malloc (sizeof (struct scm));
+  cell_vm_begin = malloc (sizeof (struct scm));
+  cell_vm_begin_eval = malloc (sizeof (struct scm));
+  cell_vm_begin_expand = malloc (sizeof (struct scm));
+  cell_vm_begin_expand_eval = malloc (sizeof (struct scm));
+  cell_vm_begin_expand_macro = malloc (sizeof (struct scm));
+  cell_vm_begin_expand_primitive_load = malloc (sizeof (struct scm));
+  cell_vm_begin_primitive_load = malloc (sizeof (struct scm));
+  cell_vm_begin_read_input_file = malloc (sizeof (struct scm));
+  cell_vm_call_with_current_continuation2 = malloc (sizeof (struct scm));
+  cell_vm_call_with_values2 = malloc (sizeof (struct scm));
+  cell_vm_eval = malloc (sizeof (struct scm));
+  cell_vm_eval2 = malloc (sizeof (struct scm));
+  cell_vm_eval_check_func = malloc (sizeof (struct scm));
+  cell_vm_eval_define = malloc (sizeof (struct scm));
+  cell_vm_eval_macro_expand_eval = malloc (sizeof (struct scm));
+  cell_vm_eval_macro_expand_expand = malloc (sizeof (struct scm));
+  cell_vm_eval_pmatch_car = malloc (sizeof (struct scm));
+  cell_vm_eval_pmatch_cdr = malloc (sizeof (struct scm));
+  cell_vm_eval_set_x = malloc (sizeof (struct scm));
+  cell_vm_evlis = malloc (sizeof (struct scm));
+  cell_vm_evlis2 = malloc (sizeof (struct scm));
+  cell_vm_evlis3 = malloc (sizeof (struct scm));
+  cell_vm_if = malloc (sizeof (struct scm));
+  cell_vm_if_expr = malloc (sizeof (struct scm));
+  cell_vm_macro_expand = malloc (sizeof (struct scm));
+  cell_vm_macro_expand_car = malloc (sizeof (struct scm));
+  cell_vm_macro_expand_cdr = malloc (sizeof (struct scm));
+  cell_vm_macro_expand_define = malloc (sizeof (struct scm));
+  cell_vm_macro_expand_define_macro = malloc (sizeof (struct scm));
+  cell_vm_macro_expand_lambda = malloc (sizeof (struct scm));
+  cell_vm_macro_expand_set_x = malloc (sizeof (struct scm));
+  cell_vm_return = malloc (sizeof (struct scm));
+  cell_symbol_dot = malloc (sizeof (struct scm));
+  cell_symbol_lambda = malloc (sizeof (struct scm));
+  cell_symbol_begin = malloc (sizeof (struct scm));
+  cell_symbol_if = malloc (sizeof (struct scm));
+  cell_symbol_quote = malloc (sizeof (struct scm));
+  cell_symbol_define = malloc (sizeof (struct scm));
+  cell_symbol_define_macro = malloc (sizeof (struct scm));
+  cell_symbol_quasiquote = malloc (sizeof (struct scm));
+  cell_symbol_unquote = malloc (sizeof (struct scm));
+  cell_symbol_unquote_splicing = malloc (sizeof (struct scm));
+  cell_symbol_syntax = malloc (sizeof (struct scm));
+  cell_symbol_quasisyntax = malloc (sizeof (struct scm));
+  cell_symbol_unsyntax = malloc (sizeof (struct scm));
+  cell_symbol_unsyntax_splicing = malloc (sizeof (struct scm));
+  cell_symbol_set_x = malloc (sizeof (struct scm));
+  cell_symbol_sc_expand = malloc (sizeof (struct scm));
+  cell_symbol_macro_expand = malloc (sizeof (struct scm));
+  cell_symbol_portable_macro_expand = malloc (sizeof (struct scm));
+  cell_symbol_sc_expander_alist = malloc (sizeof (struct scm));
+  cell_symbol_call_with_values = malloc (sizeof (struct scm));
+  cell_symbol_call_with_current_continuation = malloc (sizeof (struct scm));
+  cell_symbol_boot_module = malloc (sizeof (struct scm));
+  cell_symbol_current_module = malloc (sizeof (struct scm));
+  cell_symbol_primitive_load = malloc (sizeof (struct scm));
+  cell_symbol_read_input_file = malloc (sizeof (struct scm));
+  cell_symbol_write = malloc (sizeof (struct scm));
+  cell_symbol_display = malloc (sizeof (struct scm));
+  cell_symbol_car = malloc (sizeof (struct scm));
+  cell_symbol_cdr = malloc (sizeof (struct scm));
+  cell_symbol_not_a_number = malloc (sizeof (struct scm));
+  cell_symbol_not_a_pair = malloc (sizeof (struct scm));
+  cell_symbol_system_error = malloc (sizeof (struct scm));
+  cell_symbol_throw = malloc (sizeof (struct scm));
+  cell_symbol_unbound_variable = malloc (sizeof (struct scm));
+  cell_symbol_wrong_number_of_args = malloc (sizeof (struct scm));
+  cell_symbol_wrong_type_arg = malloc (sizeof (struct scm));
+  cell_symbol_buckets = malloc (sizeof (struct scm));
+  cell_symbol_builtin = malloc (sizeof (struct scm));
+  cell_symbol_frame = malloc (sizeof (struct scm));
+  cell_symbol_hashq_table = malloc (sizeof (struct scm));
+  cell_symbol_module = malloc (sizeof (struct scm));
+  cell_symbol_procedure = malloc (sizeof (struct scm));
+  cell_symbol_record_type = malloc (sizeof (struct scm));
+  cell_symbol_size = malloc (sizeof (struct scm));
+  cell_symbol_stack = malloc (sizeof (struct scm));
+  cell_symbol_argv = malloc (sizeof (struct scm));
+  cell_symbol_mes_datadir = malloc (sizeof (struct scm));
+  cell_symbol_mes_version = malloc (sizeof (struct scm));
+  cell_symbol_internal_time_units_per_second = malloc (sizeof (struct scm));
+  cell_symbol_compiler = malloc (sizeof (struct scm));
+  cell_symbol_arch = malloc (sizeof (struct scm));
+  cell_symbol_pmatch_car = malloc (sizeof (struct scm));
+  cell_symbol_pmatch_cdr = malloc (sizeof (struct scm));
+  cell_type_bytes = malloc (sizeof (struct scm));
+  cell_type_char = malloc (sizeof (struct scm));
+  cell_type_closure = malloc (sizeof (struct scm));
+  cell_type_continuation = malloc (sizeof (struct scm));
+  cell_type_function = malloc (sizeof (struct scm));
+  cell_type_keyword = malloc (sizeof (struct scm));
+  cell_type_macro = malloc (sizeof (struct scm));
+  cell_type_number = malloc (sizeof (struct scm));
+  cell_type_pair = malloc (sizeof (struct scm));
+  cell_type_port = malloc (sizeof (struct scm));
+  cell_type_ref = malloc (sizeof (struct scm));
+  cell_type_special = malloc (sizeof (struct scm));
+  cell_type_string = malloc (sizeof (struct scm));
+  cell_type_struct = malloc (sizeof (struct scm));
+  cell_type_symbol = malloc (sizeof (struct scm));
+  cell_type_values = malloc (sizeof (struct scm));
+  cell_type_variable = malloc (sizeof (struct scm));
+  cell_type_vector = malloc (sizeof (struct scm));
+  cell_type_broken_heart = malloc (sizeof (struct scm));
+  cell_symbol_test = malloc (sizeof (struct scm));
+  cell_test = malloc (sizeof (struct scm));
+}

src/lib.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,434 +22,156 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
-#include <assert.h>
 #include <stdlib.h>
 
-int g_depth;
-
-SCM
-display_helper (SCM x, int cont, char *sep, int fd, int write_p)
+struct scm *
+exit_ (struct scm *x)           /* ((name . "exit")) */
 {
-  fdputs (sep, fd);
-  if (g_depth == 0)
-    return cell_unspecified;
-  g_depth = g_depth - 1;
+  struct scm *y = x;
+  require (TNUMBER == y->type, "exit_ in src/lib.c didn't recieve a number\n");
+  exit (y->value);
+}
 
-  int t = TYPE (x);
-  if (t == TCHAR)
+struct scm *
+make_frame_type ()              /* ((internal)) */
+{
+  return make_struct (cell_symbol_record_type,
+                      cons (cell_symbol_frame, cons (cons (cell_symbol_procedure, cell_nil), cell_nil)),
+                      cell_unspecified);
+}
+
+
+struct scm *
+make_stack_type ()              /* ((internal)) */
+{
+  return make_struct (cell_symbol_record_type,
+                      cons (cell_symbol_stack,
+                            cons (cons (cstring_to_symbol ("frames"), cell_nil), cell_nil)),
+                      cell_unspecified);
+}
+
+struct scm *
+stack_length (struct scm *stack)
+{
+  return vector_length (struct_ref_ (stack, 3));
+}
+
+struct scm *
+stack_ref (struct scm *stack, SCM index)
+{
+  struct scm *y = struct_ref_ (stack, 3);
+  require (TVECTOR == y->type, "stack_ref in src/lib.c did not recieve a TVECTOR\n");
+  require (index < y->length, "y->length in stack_ref in src/lib.c was less than or equal to index\n");
+  struct scm *e = y->cdr + index;
+
+  if (e->type == TREF)
     {
-      if (!write_p)
-        fdputc (VALUE (x), fd);
-      else
-        {
-          fdputs ("#", fd);
-          long v = VALUE (x);
-          if (v == '\0')
-            fdputs ("\\nul", fd);
-          else if (v == '\a')
-            fdputs ("\\alarm", fd);
-          else if (v == '\b')
-            fdputs ("\\backspace", fd);
-          else if (v == '\t')
-            fdputs ("\\tab", fd);
-          else if (v == '\n')
-            fdputs ("\\newline", fd);
-          else if (v == '\v')
-            fdputs ("\\vtab", fd);
-          else if (v == '\f')
-            fdputs ("\\page", fd);
-          //Nyacc bug
-          // else if (v == '\r') fdputs ("return", fd);
-          else if (v == 13)
-            fdputs ("\\return", fd);
-          else if (v == ' ')
-            fdputs ("\\space", fd);
-          else
-            {
-              if (v >= 32 && v <= 127)
-                fdputc ('\\', fd);
-              fdputc (VALUE (x), fd);
-            }
-        }
+      return e->car;
     }
-  else if (t == TCLOSURE)
+
+  if (e->type == TCHAR)
     {
-      fdputs ("#<closure ", fd);
-      SCM circ = CADR (x);
-      SCM name = CADR (circ);
-      SCM args = CAR (CDDR (x));
-      display_helper (CAR (name), 0, "", fd, 0);
-      fdputc (' ', fd);
-      display_helper (args, 0, "", fd, 0);
-      fdputs (">", fd);
+      return make_char (e->value);
     }
-  else if (t == TMACRO)
+
+  if (e->type == TNUMBER)
     {
-      fdputs ("#<macro ", fd);
-      display_helper (CDR (x), cont, "", fd, 0);
-      fdputs (">", fd);
+      return make_number (e->value);
     }
-  else if (t == TVARIABLE)
+
+  return e;
+}
+
+struct scm *
+xassq (struct scm *x, struct scm *a)    /* for speed in core only */
+{
+  while (a != cell_nil && x != a->car->cdr)
     {
-      fdputs ("#<variable ", fd);
-      display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
-      fdputs (">", fd);
+      a = a->cdr;
     }
-  else if (t == TNUMBER)
-    {
-      fdputs (itoa (VALUE (x)), fd);
-    }
-  else if (t == TPAIR)
-    {
-      if (!cont)
-        fdputs ("(", fd);
-      if (CAR (x) == cell_circular && CADR (x) != cell_closure)
-        {
-          fdputs ("(*circ* . ", fd);
-          int i = 0;
-          x = CDR (x);
-          while (x != cell_nil && i++ < 10)
-            {
-              fdisplay_ (CAAR (x), fd, write_p);
-              fdputs (" ", fd);
-              x = CDR (x);
-            }
-          fdputs (" ...)", fd);
-        }
-      else
-        {
-          if (x && x != cell_nil)
-            fdisplay_ (CAR (x), fd, write_p);
-          if (CDR (x) && TYPE (CDR (x)) == TPAIR)
-            display_helper (CDR (x), 1, " ", fd, write_p);
-          else if (CDR (x) && CDR (x) != cell_nil)
-            {
-              if (TYPE (CDR (x)) != TPAIR)
-                fdputs (" . ", fd);
-              fdisplay_ (CDR (x), fd, write_p);
-            }
-        }
-      if (!cont)
-        fdputs (")", fd);
-    }
-  else if (t == TKEYWORD || t == TPORT || t == TSPECIAL || t == TSTRING || t == TSYMBOL)
-    {
-      if (t == TPORT)
-        {
-          fdputs ("#<port ", fd);
-          fdputs (itoa (PORT (x)), fd);
-          fdputs (" ", fd);
-          x = STRING (x);
-        }
-      if (t == TKEYWORD)
-        fdputs ("#:", fd);
-      if ((write_p && t == TSTRING) || t == TPORT)
-        fdputc ('"', fd);
-      char const *s = CSTRING (x);
-#if 0
-      s += START (x);
-      size_t length = LEN (x);
-#else
-      size_t length = LENGTH (x);
-#endif
-      for (size_t i = 0; i < length; i++)
-        {
-          long v = write_p ? s[i] : -1;
-          if (v == '\0')
-            fdputs ("\\0", fd);
-          else if (v == '\a')
-            fdputs ("\\a", fd);
-          else if (v == '\b')
-            fdputs ("\\b", fd);
-          else if (v == '\t')
-            fdputs ("\\t", fd);
-          else if (v == '\v')
-            fdputs ("\\v", fd);
-          else if (v == '\n')
-            fdputs ("\\n", fd);
-          else if (v == '\f')
-            fdputs ("\\f", fd);
-#if 1                           //__MESC__
-          //Nyacc bug
-          else if (v == 13)
-            fdputs ("\\r", fd);
-          else if (v == 27)
-            fdputs ("\\e", fd);
-#else
-          //else if (v == '\r') fdputs ("\\r", fd);
-          //Nyacc crash
-          //else if (v == '\e') fdputs ("\\e", fd);
-#endif
-          else if (v == '\\')
-            fdputs ("\\\\", fd);
-          else if (v == '"')
-            fdputs ("\\\"", fd);
-          else
-            fdputc (s[i], fd);
-        }
-      if ((write_p && t == TSTRING) || t == TPORT)
-        fdputc ('"', fd);
-      if (t == TPORT)
-        fdputs (">", fd);
-    }
-  else if (t == TREF)
-    fdisplay_ (REF (x), fd, write_p);
-  else if (t == TSTRUCT)
-    {
-      //SCM printer = STRUCT (x) + 1;
-      SCM printer = struct_ref_ (x, STRUCT_PRINTER);
-      if (TYPE (printer) == TREF)
-        printer = REF (printer);
-      if (TYPE (printer) == TCLOSURE || builtin_p (printer) == cell_t)
-        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++)
-        {
-          if (i)
-            fdputc (' ', fd);
-          fdisplay_ (VECTOR (x) + i, fd, write_p);
-        }
-      fdputc (')', fd);
-    }
-  else
-    {
-      fdputs ("<", fd);
-      fdputs (itoa (t), fd);
-      fdputs (":", fd);
-      fdputs (itoa (x), fd);
-      fdputs (">", fd);
-    }
-  return 0;
+
+  if (cell_nil == a)
+    return cell_f;
+  return a->car;
 }
 
-SCM
-display_ (SCM x)
+struct scm *
+memq (struct scm *x, struct scm *a)
 {
-  g_depth = 5;
-  return display_helper (x, 0, "", __stdout, 0);
-}
+  int t = x->type;
 
-SCM
-display_error_ (SCM x)
-{
-  g_depth = 5;
-  return display_helper (x, 0, "", __stderr, 0);
-}
-
-SCM
-display_port_ (SCM x, SCM p)
-{
-  assert (TYPE (p) == TNUMBER);
-  return fdisplay_ (x, VALUE (p), 0);
-}
-
-SCM
-write_ (SCM x)
-{
-  g_depth = 5;
-  return display_helper (x, 0, "", __stdout, 1);
-}
-
-SCM
-write_error_ (SCM x)
-{
-  g_depth = 5;
-  return display_helper (x, 0, "", __stderr, 1);
-}
-
-SCM
-write_port_ (SCM x, SCM p)
-{
-  assert (TYPE (p) == TNUMBER);
-  return fdisplay_ (x, VALUE (p), 1);
-}
-
-SCM
-fdisplay_ (SCM x, int fd, int write_p)  ///((internal))
-{
-  g_depth = 5;
-  return display_helper (x, 0, "", fd, write_p);
-}
-
-SCM
-exit_ (SCM x)                   ///((name . "exit"))
-{
-  assert (TYPE (x) == TNUMBER);
-  exit (VALUE (x));
-}
-
-SCM
-frame_printer (SCM frame)
-{
-  fdputs ("#<", __stdout);
-  display_ (struct_ref_ (frame, 2));
-  fdputc (' ', __stdout);
-  fdputs ("procedure: ", __stdout);
-  display_ (struct_ref_ (frame, 3));
-  fdputc ('>', __stdout);
-}
-
-SCM
-make_frame_type ()              ///((internal))
-{
-  SCM record_type = cell_symbol_record_type;    // FIXME
-  SCM fields = cell_nil;
-  fields = cons (cell_symbol_procedure, fields);
-  fields = cons (fields, cell_nil);
-  fields = cons (cell_symbol_frame, fields);
-  return make_struct (record_type, fields, cell_unspecified);
-}
-
-SCM
-make_frame (SCM stack, long index)
-{
-  SCM frame_type = make_frame_type ();
-  long array_index = (STACK_SIZE - (index * FRAME_SIZE));
-  SCM procedure = g_stack_array[array_index + FRAME_PROCEDURE];
-  if (!procedure)
-    procedure = cell_f;
-  SCM values = cell_nil;
-  values = cons (procedure, values);
-  values = cons (cell_symbol_frame, values);
-  return make_struct (frame_type, values, cstring_to_symbol ("frame-printer"));
-}
-
-SCM
-make_stack_type ()              ///((internal))
-{
-  SCM record_type = cell_symbol_record_type;    // FIXME
-  SCM fields = cell_nil;
-  fields = cons (cstring_to_symbol ("frames"), fields);
-  fields = cons (fields, cell_nil);
-  fields = cons (cell_symbol_stack, fields);
-  return make_struct (record_type, fields, cell_unspecified);
-}
-
-SCM
-make_stack (SCM stack)          ///((arity . n))
-{
-  SCM stack_type = make_stack_type ();
-  long size = (STACK_SIZE - g_stack) / FRAME_SIZE;
-  SCM frames = make_vector__ (size);
-  for (long i = 0; i < size; i++)
-    {
-      SCM frame = make_frame (stack, i);
-      vector_set_x_ (frames, i, frame);
-    }
-  SCM values = cell_nil;
-  values = cons (frames, values);
-  values = cons (cell_symbol_stack, values);
-  return make_struct (stack_type, values, cell_unspecified);
-}
-
-SCM
-stack_length (SCM stack)
-{
-  SCM frames = struct_ref_ (stack, 3);
-  return vector_length (frames);
-}
-
-SCM
-stack_ref (SCM stack, SCM index)
-{
-  SCM frames = struct_ref_ (stack, 3);
-  return vector_ref (frames, index);
-}
-
-SCM
-xassq (SCM x, SCM a)            ///for speed in core only
-{
-  while (a != cell_nil && x != CDAR (a))
-    a = CDR (a);
-  return a != cell_nil ? CAR (a) : cell_f;
-}
-
-SCM
-memq (SCM x, SCM a)
-{
-  int t = TYPE (x);
   if (t == TCHAR || t == TNUMBER)
     {
-      SCM v = VALUE (x);
-      while (a != cell_nil && v != VALUE (CAR (a)))
-        a = CDR (a);
+      SCM v = x->value;
+
+      while (a != cell_nil && v != a->car->value)
+        {
+          a = a->cdr;
+        }
     }
   else if (t == TKEYWORD)
     {
-      while (a != cell_nil && (TYPE (CAR (a)) != TKEYWORD || string_equal_p (x, CAR (a)) == cell_f))
-        a = CDR (a);
+      while (a != cell_nil && (a->car->type != TKEYWORD || string_equal_p (x, a->car) == cell_f))
+        {
+          a = a->cdr;
+        }
     }
   else
-    while (a != cell_nil && x != CAR (a))
-      a = CDR (a);
-  return a != cell_nil ? a : cell_f;
+    {
+      while (a != cell_nil && x != a->car)
+        {
+          a = a->cdr;
+        }
+    }
+
+  if (cell_nil == a)
+    return cell_f;
+  return a;
 }
 
-SCM
-equal2_p (SCM a, SCM b)
+struct scm *
+equal2_p (struct scm *a, struct scm *b)
 {
-equal2:
   if (a == b)
-    return cell_t;
-  if (TYPE (a) == TPAIR && TYPE (b) == TPAIR)
     {
-      if (equal2_p (CAR (a), CAR (b)) == cell_t)
-        {
-          a = CDR (a);
-          b = CDR (b);
-          goto equal2;
-        }
-      return cell_f;
-    }
-  if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
-    return string_equal_p (a, b);
-  if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
-    {
-      if (LENGTH (a) != LENGTH (b))
-        return cell_f;
-      for (long i = 0; i < LENGTH (a); i++)
-        {
-          SCM ai = VECTOR (a) + i;
-          SCM bi = VECTOR (b) + i;
-          if (TYPE (ai) == TREF)
-            ai = REF (ai);
-          if (TYPE (bi) == TREF)
-            bi = REF (bi);
-          if (equal2_p (ai, bi) == cell_f)
-            return cell_f;
-        }
       return cell_t;
     }
+
+  if (a->type == TPAIR && b->type == TPAIR)
+    {
+      if ((cell_t == equal2_p (a->car, b->car)) && (cell_t == equal2_p (a->cdr, b->cdr)))
+        return cell_t;
+      return cell_f;
+    }
+
+  if (a->type == TSTRING && b->type == TSTRING)
+    {
+      return string_equal_p (a, b);
+    }
+
+  if (a->type == TVECTOR && b->type == TVECTOR)
+    {
+      return vector_equal_p (a, b);
+    }
+
   return eq_p (a, b);
 }
 
-SCM
-last_pair (SCM x)
+struct scm *
+last_pair (struct scm *x)
 {
-  while (x != cell_nil && CDR (x) != cell_nil)
-    x = CDR (x);
+  while (x != cell_nil && x->cdr != cell_nil)
+    {
+      x = x->cdr;
+    }
+
   return x;
 }
 
-SCM
-pair_p (SCM x)
+struct scm *
+pair_p (struct scm *x)
 {
-  return TYPE (x) == TPAIR ? cell_t : cell_f;
+  if (TPAIR == x->type)
+    return cell_t;
+  return cell_f;
 }

src/math.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,212 +22,278 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
-#include <assert.h>
 #include <ctype.h>
 #include <limits.h>
 #include <stdio.h>
 #include <string.h>
 
 void
-assert_number (char const *name, SCM x)
+assert_number (char *name, struct scm *x)
 {
-  if (TYPE (x) != TNUMBER)
+  struct scm *y = x;
+  if (y->type != TNUMBER)
     {
       eputs (name);
       error (cell_symbol_not_a_number, x);
     }
 }
 
-SCM
-greater_p (SCM x)               ///((name . ">") (arity . n))
+struct scm *
+greater_p (struct scm *x)       /* ((name . ">") (arity . n)) */
 {
-  if (x == cell_nil)
-    return cell_t;
-  assert_number ("greater_p", CAR (x));
-  long n = VALUE (CAR (x));
-  x = CDR (x);
-  while (x != cell_nil)
+  struct scm *y = x;
+  if (y == cell_nil)
     {
-      assert_number ("greater_p", CAR (x));
-      if (VALUE (car (x)) >= n)
-        return cell_f;
-      n = VALUE (car (x));
-      x = cdr (x);
+      return cell_t;
     }
+
+  assert_number ("greater_p", y->car);
+  SCM n = y->car->value;
+  y = y->cdr;
+
+  while (y != cell_nil)
+    {
+      assert_number ("greater_p", y->car);
+
+      if (y->car->value >= n)
+        {
+          return cell_f;
+        }
+
+      n = y->car->value;
+      y = y->cdr;
+    }
+
   return cell_t;
 }
 
-SCM
-less_p (SCM x)                  ///((name . "<") (arity . n))
+struct scm *
+less_p (struct scm *x)          /* ((name . "<") (arity . n)) */
 {
-  if (x == cell_nil)
-    return cell_t;
-  assert_number ("less_p", CAR (x));
-  long n = VALUE (CAR (x));
-  x = CDR (x);
-  while (x != cell_nil)
+  struct scm *y = x;
+  if (y == cell_nil)
     {
-      assert_number ("less_p", CAR (x));
-      if (VALUE (car (x)) <= n)
-        return cell_f;
-      n = VALUE (car (x));
-      x = cdr (x);
+      return cell_t;
     }
+
+  assert_number ("less_p", y->car);
+  SCM n = y->car->value;
+  y = y->cdr;
+
+  while (y != cell_nil)
+    {
+      assert_number ("less_p", y->car);
+
+      if (y->car->value <= n)
+        {
+          return cell_f;
+        }
+
+      n = y->car->value;
+      y = y->cdr;
+    }
+
   return cell_t;
 }
 
-SCM
-is_p (SCM x)                    ///((name . "=") (arity . n))
+struct scm *
+is_p (struct scm *x)            /* ((name . "=") (arity . n)) */
 {
-  if (x == cell_nil)
-    return cell_t;
-  assert_number ("is_p", CAR (x));
-  long n = VALUE (CAR (x));
-  x = cdr (x);
-  while (x != cell_nil)
+  struct scm *y = x;
+  if (y == cell_nil)
     {
-      if (VALUE (car (x)) != n)
-        return cell_f;
-      x = cdr (x);
+      return cell_t;
     }
+
+  assert_number ("is_p", y->car);
+  SCM n = y->car->value;
+  y = y->cdr;
+
+  while (y != cell_nil)
+    {
+      if (y->car->value != n)
+        {
+          return cell_f;
+        }
+
+      y = y->cdr;
+    }
+
   return cell_t;
 }
 
-SCM
-minus (SCM x)                   ///((name . "-") (arity . n))
+struct scm *
+minus (struct scm *x)           /* ((name . "-") (arity . n)) */
 {
-  assert_number ("minus", CAR (x));
-  long n = VALUE (CAR (x));
-  x = cdr (x);
-  if (x == cell_nil)
-    n = -n;
-  while (x != cell_nil)
+  struct scm *y = x;
+  assert_number ("minus", y->car);
+  SCM n = y->car->value;
+  y = y->cdr;
+
+  if (y == cell_nil)
     {
-      assert_number ("minus", CAR (x));
-      n -= VALUE (car (x));
-      x = cdr (x);
+      n = -n;
     }
-  return MAKE_NUMBER (n);
+
+  while (y != cell_nil)
+    {
+      assert_number ("minus", y->car);
+      n = n - y->car->value;
+      y = y->cdr;
+    }
+
+  return make_number (n);
 }
 
-SCM
-plus (SCM x)                    ///((name . "+") (arity . n))
+struct scm *
+plus (struct scm *x)            /* ((name . "+") (arity . n)) */
 {
-  long n = 0;
-  while (x != cell_nil)
+  struct scm *y = x;
+  SCM n = 0;
+
+  while (y != cell_nil)
     {
-      assert_number ("plus", CAR (x));
-      n += VALUE (car (x));
-      x = cdr (x);
+      assert_number ("plus", y->car);
+      n = n + y->car->value;
+      y = y->cdr;
     }
-  return MAKE_NUMBER (n);
+
+  return make_number (n);
 }
 
-SCM
-divide (SCM x)                  ///((name . "/") (arity . n))
+struct scm *
+divide (struct scm *x)          /* ((name . "/") (arity . n)) */
 {
-  long n = 1;
-  if (x != cell_nil)
+  struct scm *y = x;
+  SCM n = 1;
+
+  if (y != cell_nil)
     {
-      assert_number ("divide", CAR (x));
-      n = VALUE (car (x));
-      x = cdr (x);
+      assert_number ("divide", y->car);
+      n = y->car->value;
+      y = y->cdr;
     }
-  while (x != cell_nil)
+
+  while (y != cell_nil)
     {
-      assert_number ("divide", CAR (x));
-      long y = VALUE (CAR (x));
-      if (y == 0)
-        error (cstring_to_symbol ("divide-by-zero"), x);
+      assert_number ("divide", y->car);
+
       if (!n)
-        break;
-      n /= y;
-      x = cdr (x);
+        {
+          break;
+        }
+
+      n = n / y->car->value;
+      y = y->cdr;
     }
-  return MAKE_NUMBER (n);
+
+  return make_number (n);
 }
 
-SCM
-modulo (SCM a, SCM b)
+struct scm *
+modulo (struct scm *a, struct scm *b)
 {
+  struct scm *a2 = a;
+  struct scm *b2 = b;
   assert_number ("modulo", a);
   assert_number ("modulo", b);
-  long x = VALUE (a);
-  long y = VALUE (b);
-  if (y == 0)
-    error (cstring_to_symbol ("divide-by-zero"), a);
-  while (x < 0)
-    x += y;
-  x = x ? x % y : 0;
-  return MAKE_NUMBER (x);
+  SCM x = a2->value;
+
+  x = x % b2->value;
+  if (b2->value < 0)
+    x = x + b2->value;
+
+  return make_number (x);
 }
 
-SCM
-multiply (SCM x)                ///((name . "*") (arity . n))
+struct scm *
+multiply (struct scm *x)        /* ((name . "*") (arity . n)) */
 {
-  long n = 1;
-  while (x != cell_nil)
+  struct scm *y = x;
+  SCM n = 1;
+
+  while (y != cell_nil)
     {
-      assert_number ("multiply", CAR (x));
-      n *= VALUE (car (x));
-      x = cdr (x);
+      assert_number ("multiply", y->car);
+      n = n * y->car->value;
+      y = y->cdr;
     }
-  return MAKE_NUMBER (n);
+
+  return make_number (n);
 }
 
-SCM
-logand (SCM x)                  ///((arity . n))
+struct scm *
+logand (struct scm *x)          /* ((arity . n)) */
 {
-  long n = 0;
-  while (x != cell_nil)
+  struct scm *y = x;
+  SCM n = -1;
+
+  while (y != cell_nil)
     {
-      assert_number ("multiply", CAR (x));
-      n &= VALUE (car (x));
-      x = cdr (x);
+      assert_number ("multiply", y->car);
+      n = n & y->car->value;
+      y = y->cdr;
     }
-  return MAKE_NUMBER (n);
+
+  return make_number (n);
 }
 
-SCM
-logior (SCM x)                  ///((arity . n))
+struct scm *
+logior (struct scm *x)          /* ((arity . n)) */
 {
-  long n = 0;
-  while (x != cell_nil)
+  struct scm *y = x;
+  SCM n = 0;
+
+  while (y != cell_nil)
     {
-      assert_number ("logior", CAR (x));
-      n |= VALUE (car (x));
-      x = cdr (x);
+      assert_number ("logior", y->car);
+      n = n | y->car->value;
+      y = y->cdr;
     }
-  return MAKE_NUMBER (n);
+
+  return make_number (n);
 }
 
-SCM
-lognot (SCM x)
+struct scm *
+lognot (struct scm *x)
 {
+  struct scm *y = x;
   assert_number ("lognot", x);
-  long n = ~VALUE (x);
-  return MAKE_NUMBER (n);
+  SCM n = ~y->value;
+  return make_number (n);
 }
 
-SCM
-logxor (SCM x)                  ///((arity . n))
+struct scm *
+logxor (struct scm *x)          /* ((arity . n)) */
 {
-  long n = 0;
-  while (x != cell_nil)
+  struct scm *y = x;
+  SCM n = 0;
+
+  while (y != cell_nil)
     {
-      assert_number ("logxor", CAR (x));
-      n ^= VALUE (car (x));
-      x = cdr (x);
+      assert_number ("logxor", y->car);
+      n = n ^ y->car->value;
+      y = y->cdr;
     }
-  return MAKE_NUMBER (n);
+
+  return make_number (n);
 }
 
-SCM
-ash (SCM n, SCM count)
+struct scm *
+ash (struct scm *n, struct scm *count)
 {
+  struct scm *n2 = n;
+  struct scm *count2 = count;
   assert_number ("ash", n);
   assert_number ("ash", count);
-  long cn = VALUE (n);
-  long ccount = VALUE (count);
-  return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
+  SCM cn = n2->value;
+  SCM ccount = count2->value;
+
+  SCM r;
+  if (ccount < 0)
+    r = cn >> -ccount;
+  else
+    r = cn << ccount;
+
+  return make_number (r);
 }

src/module.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
  * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,13 +22,11 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
-#include <assert.h>
-
-SCM
-make_module_type ()             ///(internal))
+struct scm *
+make_module_type ()
 {
-  SCM record_type = cell_symbol_record_type;    // FIXME
-  SCM fields = cell_nil;
+  struct scm *record_type = cell_symbol_record_type;    /* FIXME */
+  struct 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);
@@ -36,85 +35,58 @@ make_module_type ()             ///(internal))
   return make_struct (record_type, fields, cell_unspecified);
 }
 
-SCM
-make_initial_module (SCM a)     ///((internal))
+struct scm *
+module_variable (struct scm *module, struct scm *name)
 {
-  SCM module_type = make_module_type ();
-  a = acons (cell_symbol_module, module_type, a);
+  /* struct scm* locals = struct_ref_ (module, 3); */
+  struct scm *locals = module;
+  struct scm *x = assq (name, locals);
 
-  SCM hashq_type = make_hashq_type ();
-  a = acons (cell_symbol_hashq_table, hashq_type, a);
-
-  SCM name = cons (cstring_to_symbol ("boot"), cell_nil);
-  SCM globals = make_hash_table_ (0);
-  SCM locals = cell_nil;
-
-  SCM values = cell_nil;
-  values = cons (globals, values);
-  values = cons (locals, values);
-  values = cons (name, values);
-  values = cons (cell_symbol_module, values);
-  SCM module = make_struct (module_type, values, cstring_to_symbol ("module-printer"));
-  r0 = cell_nil;
-  r0 = cons (CADR (a), r0);
-  r0 = cons (CAR (a), r0);
-  m0 = module;
-  while (TYPE (a) == TPAIR)
-    {
-      module_define_x (module, CAAR (a), CDAR (a));
-      a = CDR (a);
-    }
-
-  return module;
-}
-
-SCM
-module_printer (SCM module)
-{
-  //module = m0;
-  fdputs ("#<", __stdout);
-  display_ (struct_ref_ (module, 2));
-  fdputc (' ', __stdout);
-  fdputs ("name: ", __stdout);
-  display_ (struct_ref_ (module, 3));
-  fdputc (' ', __stdout);
-  fdputs ("locals: ", __stdout);
-  display_ (struct_ref_ (module, 4));
-  fdputc (' ', __stdout);
-  SCM table = struct_ref_ (module, 5);
-  fdputs ("globals:\n  ", __stdout);
-  display_ (table);
-  fdputc ('>', __stdout);
-}
-
-SCM
-module_variable (SCM module, SCM name)
-{
-  //SCM locals = struct_ref_ (module, 3);
-  SCM locals = module;
-  SCM x = assq (name, locals);
   if (x == cell_f)
     {
-      module = m0;
-      SCM globals = struct_ref_ (module, 5);
+      struct scm *globals = struct_ref_ (M0, 5);
       x = hashq_get_handle (globals, name, cell_f);
     }
+
   return x;
 }
 
-SCM
-module_ref (SCM module, SCM name)
+
+struct scm *
+module_ref (struct scm *module, struct scm *name)
 {
-  SCM x = module_variable (module, name);
-  if (x == cell_f)
-    return cell_undefined;
-  return CDR (x);
+  struct scm *y = module_variable (module, name);
+
+  if (y == cell_f)
+    {
+      return cell_undefined;
+    }
+
+  return y->cdr;
 }
 
-SCM
-module_define_x (SCM module, SCM name, SCM value)
+struct scm *
+module_define_x (struct scm *module, struct scm *name, struct scm *value)
 {
-  module = m0;
-  SCM globals = struct_ref_ (module, 5);
+  struct scm *globals = struct_ref_ (M0, 5);
   return hashq_set_x (globals, name, value);
 }
+
+/* External functions */
+struct scm *
+module_variable_ (struct scm *module, struct scm *name) /* EXTERNAL */
+{
+  return module_variable (module, name);
+}
+
+struct scm *
+module_ref_ (struct scm *module, struct scm *name)      /* EXTERNAL */
+{
+  return module_ref (module, name);
+}
+
+struct scm *
+make_module_type_ ()            /* EXTERNAL */
+{
+  return make_module_type ();
+}

src/posix.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,17 +22,26 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
-#include <assert.h>
 #include <fcntl.h>
 #include <limits.h>
+#include <stdarg.h>
 #include <stdlib.h>
 #include <string.h>
 #include <sys/stat.h>
-#include <time.h>
 #include <sys/time.h>
 #include <sys/wait.h>
+#include <time.h>
 #include <unistd.h>
 
+int
+get_env_value (char *c, int alt)
+{
+  char *s = getenv (c);
+  if (NULL == s)
+    return alt;
+  return numerate_string (s);
+}
+
 int
 peekchar ()
 {
@@ -41,12 +51,17 @@ peekchar ()
       unreadchar (c);
       return c;
     }
-  SCM port = current_input_port ();
-  SCM string = STRING (port);
-  size_t length = LENGTH (string);
+
+  struct scm *port = current_input_port ();
+  struct scm *string = port->cdr;
+  size_t length = string->length;
+
   if (!length)
-    return -1;
-  char const *p = CSTRING (string);
+    {
+      return -1;
+    }
+
+  char *p = string->cdr->string;
   return p[0];
 }
 
@@ -54,15 +69,23 @@ int
 readchar ()
 {
   if (__stdin >= 0)
-    return fdgetc (__stdin);
-  SCM port = current_input_port ();
-  SCM string = STRING (port);
-  size_t length = LENGTH (string);
+    {
+      return fdgetc (__stdin);
+    }
+
+  struct scm *port = current_input_port ();
+  struct scm *string = port->cdr;
+  size_t length = string->length;
+
   if (!length)
-    return -1;
-  char const *p = CSTRING (string);
-  int c = *p++;
-  STRING (port) = make_string (p, length - 1);
+    {
+      return -1;
+    }
+
+  char *p = string->cdr->string;
+  int c = p[0];
+  p = p + 1;
+  port->cdr = make_string (p, length - 1);
   return c;
 }
 
@@ -70,217 +93,281 @@ int
 unreadchar (int c)
 {
   if (__stdin >= 0)
-    return fdungetc (c, __stdin);
-  SCM port = current_input_port ();
-  SCM string = STRING (port);
-  size_t length = LENGTH (string);
-  char *p = CSTRING (string);
-  p--;
+    {
+      return fdungetc (c, __stdin);
+    }
+
+  struct scm *port = current_input_port ();
+  struct scm *string = port->cdr;
+  size_t length = string->length;
+  char *p = string->cdr->string;
+  p = p - 1;
   string = make_string (p, length + 1);
-  p = CSTRING (string);
+  p = string->cdr->string;
   p[0] = c;
-  STRING (port) = string;
+  port->cdr = string;
   return c;
 }
 
-SCM
+struct scm *
 peek_byte ()
 {
-  return MAKE_NUMBER (peekchar ());
+  return make_number (peekchar ());
 }
 
-SCM
+struct scm *
 read_byte ()
 {
-  return MAKE_NUMBER (readchar ());
+  return make_number (readchar ());
 }
 
-SCM
-unread_byte (SCM i)
+struct scm *
+unread_byte (struct scm *i)
 {
-  unreadchar (VALUE (i));
-  return i;
+  struct scm *x = i;
+  unreadchar (x->value);
+  return x;
 }
 
-SCM
+struct scm *
 peek_char ()
 {
-  return MAKE_CHAR (peekchar ());
+  return make_char (peekchar ());
 }
 
-SCM
-read_char (SCM port)            ///((arity . n))
+struct scm *
+read_char (struct scm *port)    ///((arity . n))
 {
   int fd = __stdin;
-  if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
-    __stdin = VALUE (CAR (port));
-  SCM c = MAKE_CHAR (readchar ());
+  struct scm *p = port;
+
+  if (p->type == TPAIR && p->car->type == TNUMBER)
+    {
+      __stdin = p->car->value;
+    }
+
+  struct scm *c = make_char (readchar ());
   __stdin = fd;
   return c;
 }
 
-SCM
-unread_char (SCM i)
+struct scm *
+unread_char (struct scm *i)
 {
-  unreadchar (VALUE (i));
-  return i;
+  struct scm *x = i;
+  unreadchar (x->value);
+  return x;
 }
 
-SCM
-write_char (SCM i)              ///((arity . n))
+char *
+env_lookup (char *token, char **envp)
 {
-  write_byte (i);
-  return i;
+  if (NULL == envp)
+    return NULL;
+  int i = 0;
+  char *ret = NULL;
+  do
+    {
+      if (!strcmp (token, envp[i]))
+        ret = envp[i];
+      if (NULL != ret)
+        return ret;
+      i = i + 1;
+    }
+  while (NULL != envp[i]);
+  return NULL;
 }
 
-SCM
-write_byte (SCM x)              ///((arity . n))
+struct scm *
+getenv_ (struct scm *s)         ///((name . "getenv"))
 {
-  SCM c = car (x);
-  SCM p = cdr (x);
-  int fd = __stdout;
-  if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER && VALUE (CAR (p)) != 1)
-    fd = VALUE (CAR (p));
-  if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER && VALUE (CAR (p)) == 2)
-    fd = __stderr;
-  char cc = VALUE (c);
-  write (fd, (char *) &cc, 1);
-#if !__MESC__
-  assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
-#endif
-  return c;
+  struct scm *x = s;
+  char *p = x->cdr->string;
+  char *pass = env_lookup (p, global_envp);
+  if (NULL == pass)
+    return cell_f;
+  return make_string_ (pass);
 }
 
-SCM
-getenv_ (SCM s)                 ///((name . "getenv"))
+struct scm *
+setenv_ (struct scm *s, struct scm *v)  ///((name . "setenv"))
 {
-  char *p;
-  p = getenv (CSTRING (s));
-  return p ? MAKE_STRING0 (p) : cell_f;
-}
-
-SCM
-setenv_ (SCM s, SCM v)          ///((name . "setenv"))
-{
-  char buf[1024];
-  strcpy (buf, CSTRING (s));
-  setenv (buf, CSTRING (v), 1);
+  struct scm *a = s;
+  struct scm *b = v;
+  char *p1 = a->cdr->string;
+  char *p2 = b->cdr->string;
+  setenv (p1, p2, 1);
   return cell_unspecified;
 }
 
-SCM
-access_p (SCM file_name, SCM mode)
+struct scm *
+access_p (struct scm *file_name, struct scm *mode)
 {
-  return access (CSTRING (file_name), VALUE (mode)) == 0 ? cell_t : cell_f;
+  struct scm *f = file_name;
+  struct scm *m = mode;
+  char *p = f->cdr->string;
+  return access (p, m->value) == 0 ? cell_t : cell_f;
 }
 
-SCM
+struct scm *
 current_input_port ()
 {
   if (__stdin >= 0)
-    return MAKE_NUMBER (__stdin);
-  SCM x = g_ports;
-  while (x && PORT (CAR (x)) != __stdin)
-    x = CDR (x);
-  return CAR (x);
+    {
+      return make_number (__stdin);
+    }
+
+  struct scm *x = g_ports;
+
+  while (x->car->port != __stdin)
+    {
+      x = x->cdr;
+    }
+
+  return x->car;
 }
 
-SCM
-open_input_file (SCM file_name)
+struct scm *
+open_input_file (struct scm *file_name)
 {
-  return MAKE_NUMBER (mes_open (CSTRING (file_name), O_RDONLY, 0));
+  struct scm *f = file_name;
+  char *p = f->cdr->string;
+  return make_number (mes_open (p, O_RDONLY, 0));
 }
 
-SCM
-open_input_string (SCM string)
+struct scm *
+open_input_string (struct scm *string)
 {
-  SCM port = MAKE_STRING_PORT (string);
+  struct scm *port = make_port (-length__ (g_ports) - 2, string);
   g_ports = cons (port, g_ports);
   return port;
 }
 
-SCM
-set_current_input_port (SCM port)
+struct scm *
+set_current_input_port (struct scm *port)
 {
-  SCM prev = current_input_port ();
-  if (TYPE (port) == TNUMBER)
-    __stdin = VALUE (port) ? VALUE (port) : STDIN;
-  else if (TYPE (port) == TPORT)
-    __stdin = PORT (port);
+  struct scm *prev = current_input_port ();
+  struct scm *x = port;
+
+  if (x->type == TNUMBER)
+    {
+      __stdin = x->value ? x->value : STDIN;
+    }
+  else if (x->type == TPORT)
+    {
+      __stdin = x->rac;
+    }
+
   return prev;
 }
 
-SCM
+struct scm *
 current_output_port ()
 {
-  return MAKE_NUMBER (__stdout);
+  return make_number (__stdout);
 }
 
-SCM
+struct scm *
 current_error_port ()
 {
-  return MAKE_NUMBER (__stderr);
+  return make_number (__stderr);
 }
 
-SCM
-open_output_file (SCM x)        ///((arity . n))
+struct scm *
+open_output_file (struct scm *x)        ///((arity . n))
 {
-  SCM file_name = car (x);
-  x = cdr (x);
+  struct scm *y = x;
+  struct scm *f = y->car;
+  y = y->cdr;
   int mode = S_IRUSR | S_IWUSR;
-  if (TYPE (x) == TPAIR && TYPE (car (x)) == TNUMBER)
-    mode = VALUE (car (x));
-  return MAKE_NUMBER (mes_open (CSTRING (file_name), O_WRONLY | O_CREAT | O_TRUNC, mode));
+
+  if (y->type == TPAIR && f->type == TNUMBER)
+    {
+      mode = f->value;
+    }
+
+  char *p = f->cdr->string;
+  SCM fl = mes_open (p, O_WRONLY | O_CREAT | O_TRUNC, mode);
+  struct scm *handle = make_number (fl);
+  return handle;
 }
 
-SCM
-set_current_output_port (SCM port)
+struct scm *
+set_current_output_port (struct scm *port)
 {
-  __stdout = VALUE (port) ? VALUE (port) : STDOUT;
+  struct scm *p = port;
+  __stdout = p->value ? p->value : STDOUT;
   return current_output_port ();
 }
 
-SCM
-set_current_error_port (SCM port)
+struct scm *
+set_current_error_port (struct scm *port)
 {
-  __stderr = VALUE (port) ? VALUE (port) : STDERR;
+  struct scm *p = port;
+  __stderr = p->value ? p->value : STDERR;
   return current_error_port ();
 }
 
-SCM
-chmod_ (SCM file_name, SCM mode)        ///((name . "chmod"))
+struct scm *
+chmod_ (struct scm *file_name, struct scm *mode)        ///((name . "chmod"))
 {
-  chmod (CSTRING (file_name), VALUE (mode));
+  struct scm *f = file_name;
+  struct scm *m = mode;
+  char *p = f->cdr->string;
+  chmod (p, m->value);
   return cell_unspecified;
 }
 
-SCM
-isatty_p (SCM port)
+struct scm *
+isatty_p (struct scm *port)
 {
-  return isatty (VALUE (port)) ? cell_t : cell_f;
+  struct scm *p = port;
+  return isatty (p->value) ? cell_t : cell_f;
 }
 
-SCM
+struct scm *
 primitive_fork ()
 {
-  return MAKE_NUMBER (fork ());
+  return make_number (fork ());
 }
 
-SCM
-execl_ (SCM file_name, SCM args)        ///((name . "execl"))
+void
+require (int bool, char *error)
 {
+  if (!bool)
+    {
+      eputs (error);
+      exit (EXIT_FAILURE);
+    }
+}
+
+struct scm *
+execl_ (struct scm *file_name, struct scm *args)        ///((name . "execl"))
+{
+  struct scm *f = file_name;
+  struct scm *a = args;
   char *c_argv[1000];           // POSIX minimum 4096
   int i = 0;
 
   if (length__ (args) > 1000)
-    error (cell_symbol_system_error,
-           cons (file_name, cons (MAKE_STRING0 ("too many arguments"), cons (file_name, args))));
-  c_argv[i++] = CSTRING (file_name);
-  while (args != cell_nil)
     {
-      assert (TYPE (CAR (args)) == TSTRING);
-      c_argv[i++] = CSTRING (CAR (args));
-      args = CDR (args);
+      error (cell_symbol_system_error,
+             cons (file_name, cons (make_string_ ("too many arguments"), cons (file_name, args))));
+    }
+
+  char *p = f->cdr->string;
+  c_argv[i] = p;
+  i = i + 1;
+
+  while (a != cell_nil)
+    {
+      struct scm *aa = a->car;
+      assert (aa->type == TSTRING);
+      p = aa->cdr->string;
+      c_argv[i] = p;
+      i = i + 1;
+      a = a->cdr;
+
       if (g_debug > 2)
         {
           eputs ("arg[");
@@ -290,16 +377,19 @@ execl_ (SCM file_name, SCM args)        ///((name . "execl"))
           eputs ("\n");
         }
     }
+
   c_argv[i] = 0;
-  return MAKE_NUMBER (execv (c_argv[0], c_argv));
+  return make_number (execv (c_argv[0], c_argv));
 }
 
-SCM
-waitpid_ (SCM pid, SCM options)
+struct scm *
+waitpid_ (struct scm *pid, struct scm *options)
 {
+  struct scm *p = pid;
+  struct scm *o = options;
   int status;
-  int child = waitpid (VALUE (pid), &status, VALUE (options));
-  return cons (MAKE_NUMBER (child), MAKE_NUMBER (status));
+  int child = waitpid (p->value, &status, o->value);
+  return cons (make_number (child), make_number (status));
 }
 
 #if __x86_64__
@@ -311,66 +401,71 @@ waitpid_ (SCM pid, SCM options)
 #endif
 
 struct timespec g_start_time;
-SCM
-init_time (SCM a)               ///((internal))
+struct scm *
+init_time (struct scm *a)       ///((internal))
 {
   clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &g_start_time);
-  a = acons (cell_symbol_internal_time_units_per_second, MAKE_NUMBER (TIME_UNITS_PER_SECOND), a);
+  return acons (cell_symbol_internal_time_units_per_second, make_number (TIME_UNITS_PER_SECOND), a);
 }
 
-SCM
+struct scm *
 current_time ()
 {
-  return MAKE_NUMBER (time (0));
+  return make_number (time (0));
 }
 
-SCM
+struct scm *
 gettimeofday_ ()                ///((name . "gettimeofday"))
 {
   struct timeval time;
   gettimeofday (&time, 0);
-  return cons (MAKE_NUMBER (time.tv_sec), MAKE_NUMBER (time.tv_usec));
+  return cons (make_number (time.tv_sec), make_number (time.tv_usec));
 }
 
-long
-seconds_and_nanoseconds_to_long (long s, long ns)
+SCM
+seconds_and_nanoseconds_to_long (SCM s, SCM ns)
 {
   return s * TIME_UNITS_PER_SECOND + ns / (1000000000 / TIME_UNITS_PER_SECOND);
 }
 
-SCM
+struct scm *
 get_internal_run_time ()
 {
   struct timespec ts;
   clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts);
-  long time = seconds_and_nanoseconds_to_long (ts.tv_sec - g_start_time.tv_sec,
-                                               ts.tv_nsec - g_start_time.tv_nsec);
-  return MAKE_NUMBER (time);
+  SCM time =
+    seconds_and_nanoseconds_to_long (ts.tv_sec - g_start_time.tv_sec, ts.tv_nsec - g_start_time.tv_nsec);
+  return make_number (time);
 }
 
-SCM
+struct scm *
 getcwd_ ()                      ///((name . "getcwd"))
 {
   char buf[PATH_MAX];
-  return MAKE_STRING0 (getcwd (buf, PATH_MAX));
+  return make_string_ (getcwd (buf, PATH_MAX));
 }
 
-SCM
-dup_ (SCM port)                 ///((name . "dup"))
+struct scm *
+dup_ (struct scm *port)         ///((name . "dup"))
 {
-  return MAKE_NUMBER (dup (VALUE (port)));
+  struct scm *p = port;
+  return make_number (dup (p->value));
 }
 
-SCM
-dup2_ (SCM old, SCM new)        ///((name . "dup2"))
+struct scm *
+dup2_ (struct scm *old, struct scm *new)        ///((name . "dup2"))
 {
-  dup2 (VALUE (old), VALUE (new));
+  struct scm *o = old;
+  struct scm *n = new;
+  dup2 (o->value, n->value);
   return cell_unspecified;
 }
 
-SCM
-delete_file (SCM file_name)
+struct scm *
+delete_file (struct scm *file_name)
 {
-  unlink (CSTRING (file_name));
+  struct scm *f = file_name;
+  char *p = f->cdr->string;
+  unlink (p);
   return cell_unspecified;
 }

src/printer.c

@@ -0,0 +1,401 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians
+ *
+ * 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 "mes/mes.h"
+#include <unistd.h>
+
+// CONSTANT STRUCT_PRINTER 1
+#define STRUCT_PRINTER 1
+
+/* Globals */
+int g_depth;
+
+struct scm *
+display_helper (struct scm *x, int cont, char *sep, int fd, int write_p)
+{
+  struct scm *y = x;
+  fdputs (sep, fd);
+
+  if (g_depth == 0)
+    {
+      return cell_unspecified;
+    }
+
+  g_depth = g_depth - 1;
+  int t = y->type;
+
+  if (t == TCHAR)
+    {
+      if (!write_p)
+        {
+          fdputc (y->value, fd);
+        }
+      else
+        {
+          fdputc ('#', fd);
+          /*
+          fd_print (char_lookup (y->value, TRUE), fd);
+          */
+          fdputs (char_lookup (y->value, TRUE), fd);
+        }
+    }
+  else if (t == TCLOSURE)
+    {
+      fdputs ("#<closure ", fd);
+      struct scm *name = y->cdr->car->cdr->car;
+      struct scm *args = y->cdr->cdr->car->car;
+      display_helper (name->car, 0, "", fd, 0);
+      fdputc (' ', fd);
+      display_helper (args, 0, "", fd, 0);
+      fdputc ('>', fd);
+    }
+  else if (t == TMACRO)
+    {
+      fdputs ("#<macro ", fd);
+      display_helper (y->cdr, cont, "", fd, 0);
+      fdputc ('>', fd);
+    }
+  else if (t == TVARIABLE)
+    {
+      fdputs ("#<variable ", fd);
+      display_helper (y->car->car, cont, "", fd, 0);
+      fdputc ('>', fd);
+    }
+  else if (t == TNUMBER)
+    {
+      fdputs (itoa (y->value), fd);
+    }
+  else if (t == TPAIR)
+    {
+      if (!cont)
+        fdputc ('(', fd);
+
+      if (y->car == cell_circular && y->cdr->car != cell_closure)
+        {
+          fdputs ("(*circ* . ", fd);
+          int i = 0;
+          y = y->cdr;
+
+          while (y != cell_nil && i < 10)
+            {
+              i = i + 1;
+              fdisplay_ (y->car->car, fd, write_p);
+              fdputc (' ', fd);
+              y = y->cdr;
+            }
+
+          fdputs (" ...)", fd);
+        }
+      else
+        {
+          if (y != cell_nil)
+            {
+              fdisplay_ (y->car, fd, write_p);
+            }
+
+          if (y->cdr->type == TPAIR)
+            {
+              display_helper (y->cdr, 1, " ", fd, write_p);
+            }
+          else if (y->cdr != cell_nil)
+            {
+              if (y->cdr->type != TPAIR)
+                {
+                  fdputs (" . ", fd);
+                }
+
+              fdisplay_ (y->cdr, fd, write_p);
+            }
+        }
+
+      if (!cont)
+        fdputc (')', fd);
+    }
+  else if (t == TPORT)
+    {
+      fdputs ("#<port ", fd);
+      fdputs (itoa (y->port), fd);
+      fdputc (' ', fd);
+      char *s = y->cdr->cdr->string;
+      raw_print (s, fd);
+      fdputs ("\">", fd);
+    }
+  else if (t == TKEYWORD)
+    {
+      fdputs ("#:", fd);
+      char *s = y->cdr->string;
+      raw_print (s, fd);
+    }
+  else if (t == TSTRING)
+    {
+      if (write_p)
+        fdputc ('"', fd);
+      char *s = y->cdr->string;
+      /*
+      fd_print (s, fd);
+      */
+      fdputs (s, fd);
+      if (write_p)
+        fdputc ('"', fd);
+    }
+  else if (t == TSPECIAL)
+    {
+      char *s = y->cdr->string;
+      raw_print (s, fd);
+    }
+  else if (t == TSYMBOL)
+    {
+      char *s = y->cdr->string;
+      raw_print (s, fd);
+    }
+  else if (t == TREF)
+    {
+      fdisplay_ (y->car, fd, write_p);
+    }
+  else if (t == TSTRUCT)
+    {
+      /* struct scm* printer = STRUCT (x) + 1; */
+      struct scm *printer = struct_ref_ (x, STRUCT_PRINTER);
+
+      if (printer->type == TREF)
+        {
+          printer = printer->car;
+        }
+
+      if (printer->type == TCLOSURE || builtin_p (printer) == cell_t)
+        {
+          apply (printer, cons (x, cell_nil));
+        }
+      else
+        {
+          fdputs ("#<", fd);
+          fdisplay_ (y->struc, fd, write_p);
+
+          SCM size = y->length;
+          SCM i;
+
+          for (i = 2; i < size; i = i + 1)
+            {
+              fdputc (' ', fd);
+              fdisplay_ (y->struc + i, fd, write_p);
+            }
+
+          fdputc ('>', fd);
+        }
+    }
+  else if (t == TVECTOR)
+    {
+      fdputs ("#(", fd);
+
+      fdisplay_ (y->vector, fd, write_p);
+      SCM i;
+      for (i = 1; i < y->length; i = i + 1)
+        {
+          fdputs (" ", fd);
+          fdisplay_ (y->vector + i, fd, write_p);
+        }
+
+      fdputc (')', fd);
+    }
+  else
+    {
+      fdputs ("<", fd);
+      fdputs (itoa (t), fd);
+      fdputs (":", fd);
+      fdputs (itoa (x->type), fd);
+      fdputs (":", fd);
+      fdputs (itoa (x->rac), fd);
+      fdputs (":", fd);
+      fdputs (itoa (x->value), fd);
+      fdputs (">", fd);
+    }
+
+  return 0;
+}
+
+struct scm *
+display_ (struct scm *x)
+{
+  g_depth = 5;
+  return display_helper (x, 0, "", __stdout, 0);
+}
+
+struct scm *
+display_error_ (struct scm *x)
+{
+  g_depth = 5;
+  return display_helper (x, 0, "", __stderr, 0);
+}
+
+struct scm *
+display_port_ (struct scm *x, struct scm *p)
+{
+  struct scm *p2 = p;
+  require (TNUMBER == p2->type, "src/printer.c: display_port_ did not recieve TNUMBER\n");
+  return fdisplay_ (x, p2->value, 0);
+}
+
+struct scm *
+write_ (struct scm *x)
+{
+  g_depth = 5;
+  return display_helper (x, 0, "", __stdout, 1);
+}
+
+struct scm *
+write_error_ (struct scm *x)
+{
+  g_depth = 5;
+  return display_helper (x, 0, "", __stderr, 1);
+}
+
+struct scm *
+write_port_ (struct scm *x, struct scm *p)
+{
+  struct scm *p2 = p;
+  require (TNUMBER == p2->type, "mes_printer: write_port_ did not recieve TNUMBER\n");
+  return fdisplay_ (x, p2->value, 1);
+}
+
+struct scm *
+fdisplay_ (struct scm *x, int fd, int write_p)  /* ((internal)) */
+{
+  g_depth = 5;
+  return display_helper (x, 0, "", fd, write_p);
+}
+
+struct scm *
+frame_printer (struct scm *frame)
+{
+  fdputs ("#<", __stdout);
+  display_ (struct_ref_ (frame, 2));
+  fdputs (" procedure: ", __stdout);
+  display_ (struct_ref_ (frame, 3));
+  fdputc ('>', __stdout);
+  return cell_unspecified;
+}
+
+struct scm *
+hash_table_printer (struct scm *table)
+{
+  fdputs ("#<", __stdout);
+  display_ (struct_ref_ (table, 2));
+  fdputc (' ', __stdout);
+  fdputs ("size: ", __stdout);
+  display_ (struct_ref_ (table, 3));
+  fdputc (' ', __stdout);
+  struct scm *buckets = struct_ref_ (table, 4);
+  fdputs ("buckets: ", __stdout);
+
+  struct scm *ybuckets = buckets;
+  for (int i = 0; i < ybuckets->length; i++)
+    {
+      struct scm *f = vector_ref_ (buckets, i);
+
+      if (f != cell_unspecified)
+        {
+          fdputc ('[', __stdout);
+
+          while (f->type == TPAIR)
+            {
+              write_ (f->car->car);
+              f = f->cdr;
+
+              if (f->type == TPAIR)
+                {
+                  fdputc (' ', __stdout);
+                }
+            }
+
+          fdputs ("]\n  ", __stdout);
+        }
+    }
+
+  fdputc ('>', __stdout);
+  return cell_unspecified;
+}
+
+struct scm *
+module_printer (struct scm *module)
+{
+  /* module = M0; */
+  fdputs ("#<", __stdout);
+  display_ (struct_ref_ (module, 2));
+  fdputc (' ', __stdout);
+  fdputs ("name: ", __stdout);
+  display_ (struct_ref_ (module, 3));
+  fdputc (' ', __stdout);
+  fdputs ("locals: ", __stdout);
+  display_ (struct_ref_ (module, 4));
+  fdputc (' ', __stdout);
+  struct scm *table = struct_ref_ (module, 5);
+  fdputs ("globals:\n  ", __stdout);
+  display_ (table);
+  fdputc ('>', __stdout);
+  return cell_unspecified;
+}
+
+void
+assert_max_string (int i, char *msg, char *string)
+{
+  if (i > MAX_STRING)
+    {
+      raw_print (msg, __stderr);
+      raw_print (":string too long[", __stderr);
+      raw_print (itoa (i), __stderr);
+      raw_print ("]:", __stderr);
+      string[MAX_STRING - 1] = 0;
+      raw_print (string, __stderr);
+      error (cell_symbol_system_error, cell_f);
+    }
+}
+
+struct scm *
+write_byte (struct scm *x)      /* ((arity . n)) */
+{
+  struct scm *y = x;
+  struct scm *c = y->car;
+  struct scm *p = y->cdr;
+  struct scm *pp = p->car;
+  int fd = __stdout;
+
+  if (p->type == TPAIR && pp->type == TNUMBER)
+    {
+      fd = pp->value;
+    }
+
+  if (1 == fd)
+    fd = __stdout;
+  if (2 == fd)
+    fd = __stderr;
+
+  fdputc (fd, c->string[0]);
+  require (c->type == TNUMBER || c->type == TCHAR, "src/printer.c: write_byte was not TNUMBER or TCHAR\n");
+  return c;
+}
+
+struct scm *
+write_char (struct scm *i)      /* ((arity . n)) */
+{
+  struct scm *x = i;
+  write_byte (x);
+  return x;
+}

src/reader.c

@@ -1,7 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
- * Copyright © 2018 Jeremiah Orians <jeremiah@pdp10.guru>
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018,2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,25 +21,31 @@
 
 #include "mes/lib.h"
 #include "mes/mes.h"
-
-#include <assert.h>
 #include <ctype.h>
 #include <stdio.h>
 #include <string.h>
 
-SCM
-read_input_file_env_ (SCM e, SCM a)
+struct scm *reader_read_sexp_ (int c, struct scm *a);
+struct scm *
+read_env (struct scm *a)
+{
+  return reader_read_sexp_ (readchar (), a);
+}
+
+struct scm *
+read_input_file_env_ (struct scm *e, struct scm *a)
 {
   if (e == cell_nil)
-    return e;
+    {
+      return cell_nil;
+    }
+
   return cons (e, read_input_file_env_ (read_env (a), a));
 }
 
-SCM
-read_input_file_env (SCM a)
+struct scm *
+read_input_file_env ()
 {
-  //r0 = a;
-  //return read_input_file_env_ (read_env (r0), r0);
   return read_input_file_env_ (read_env (cell_nil), cell_nil);
 }
 
@@ -52,87 +58,87 @@ reader_read_line_comment (int c)
         return c;
       c = readchar ();
     }
-  error (cell_symbol_system_error, MAKE_STRING0 ("reader_read_line_comment"));
-}
 
-SCM reader_read_block_comment (int s, int c);
-SCM reader_read_hash (int c, SCM a);
-SCM reader_read_list (int c, SCM a);
-
-int
-reader_identifier_p (int c)
-{
-  return (c > ' ' && c <= '~' && c != '"' && c != ';' && c != '(' && c != ')' && c != EOF);
+  error (cell_symbol_system_error, make_string_ ("reader_read_line_comment"));
+  exit (EXIT_FAILURE);
 }
 
 int
 reader_end_of_word_p (int c)
 {
-  return (c == '"' || c == ';' || c == '(' || c == ')' || isspace (c) || c == EOF);
+  return in_set (c, "\";() \t\n\r") || c == EOF;
 }
 
-SCM
+struct scm *
 reader_read_identifier_or_number (int c)
 {
   int i = 0;
-  long n = 0;
-  int negative_p = 0;
-  if (c == '+' && isdigit (peekchar ()))
-    c = readchar ();
-  else if (c == '-' && isdigit (peekchar ()))
-    {
-      negative_p = 1;
-      c = readchar ();
-    }
-  while (isdigit (c))
-    {
-      g_buf[i++] = c;
-      n *= 10;
-      n += c - '0';
-      c = readchar ();
-    }
-  if (reader_end_of_word_p (c))
-    {
-      unreadchar (c);
-      if (negative_p)
-        n = 0 - n;
-      return MAKE_NUMBER (n);
-    }
-  /* Fallthrough: Note that `4a', `+1b' are identifiers */
+
+  /* Fallthrough: Note that `+', `-', `4a', `+1b' are identifiers */
   while (!reader_end_of_word_p (c))
     {
       g_buf[i++] = c;
       c = readchar ();
     }
+
   unreadchar (c);
   g_buf[i] = 0;
+
+  SCM number = numerate_string (g_buf);
+
+  if ((0 != number || '0' == g_buf[0]))
+    {
+      return make_number (number);
+    }
   return cstring_to_symbol (g_buf);
 }
 
-SCM
-reader_read_sexp_ (int c, SCM a)
+struct scm *reader_read_hash (int c, struct scm *a);
+struct scm *reader_read_list (int c, struct scm *a);
+struct scm *reader_read_string ();
+
+struct scm *
+reader_read_sexp_ (int c, struct scm *a)
 {
 reset_reader:
+
   if (c == EOF)
-    return cell_nil;
+    {
+      return cell_nil;
+    }
+
   if (c == ';')
     {
       c = reader_read_line_comment (c);
       goto reset_reader;
     }
-  if ((c == ' ') || (c == '\t') || (c == '\n') || (c == '\f'))
+
+  if (in_set (c, " \t\n\f"))
     {
       c = readchar ();
       goto reset_reader;
     }
+
   if (c == '(')
-    return reader_read_list (readchar (), a);
+    {
+      return reader_read_list (readchar (), a);
+    }
+
   if (c == ')')
-    return cell_nil;
+    {
+      return cell_nil;
+    }
+
   if (c == '#')
-    return reader_read_hash (readchar (), a);
+    {
+      return reader_read_hash (readchar (), a);
+    }
+
   if (c == '`')
-    return cons (cell_symbol_quasiquote, cons (reader_read_sexp_ (readchar (), a), cell_nil));
+    {
+      return cons (cell_symbol_quasiquote, cons (reader_read_sexp_ (readchar (), a), cell_nil));
+    }
+
   if (c == ',')
     {
       if (peekchar () == '@')
@@ -140,79 +146,175 @@ reset_reader:
           readchar ();
           return cons (cell_symbol_unquote_splicing, cons (reader_read_sexp_ (readchar (), a), cell_nil));
         }
+
       return cons (cell_symbol_unquote, cons (reader_read_sexp_ (readchar (), a), cell_nil));
     }
+
   if (c == '\'')
-    return cons (cell_symbol_quote, cons (reader_read_sexp_ (readchar (), a), cell_nil));
+    {
+      return cons (cell_symbol_quote, cons (reader_read_sexp_ (readchar (), a), cell_nil));
+    }
+
   if (c == '"')
-    return reader_read_string ();
-  if (c == '.' && (!reader_identifier_p (peekchar ())))
-    return cell_dot;
+    {
+      return reader_read_string ();
+    }
+
+  if (c == '.' && (reader_end_of_word_p (peekchar ())))
+    {
+      return cell_dot;
+    }
+
   return reader_read_identifier_or_number (c);
 }
 
+int
+reader_read_block_comment (int s, int c)
+{
+  if (c == s && peekchar () == '#')
+    {
+      return readchar ();
+    }
+
+  return reader_read_block_comment (s, readchar ());
+}
+
 int
 reader_eat_whitespace (int c)
 {
   while (isspace (c))
-    c = readchar ();
+    {
+      c = readchar ();
+    }
+
   if (c == ';')
-    return reader_eat_whitespace (reader_read_line_comment (c));
+    {
+      return reader_eat_whitespace (reader_read_line_comment (c));
+    }
+
   if (c == '#' && (peekchar () == '!' || peekchar () == '|'))
     {
       c = readchar ();
       reader_read_block_comment (c, readchar ());
       return reader_eat_whitespace (readchar ());
     }
+
   return c;
 }
 
-SCM
-reader_read_list (int c, SCM a)
+struct scm *
+reader_read_list (int c, struct scm *a)
 {
   c = reader_eat_whitespace (c);
+
   if (c == ')')
-    return cell_nil;
+    {
+      return cell_nil;
+    }
+
   if (c == EOF)
-    error (cell_symbol_not_a_pair, MAKE_STRING0 ("EOF in list"));
+    {
+      error (cell_symbol_not_a_pair, make_string_ ("EOF in list"));
+    }
+
   //return cell_nil;
-  SCM s = reader_read_sexp_ (c, a);
+  struct scm *s = reader_read_sexp_ (c, a);
+
   if (s == cell_dot)
-    return CAR (reader_read_list (readchar (), a));
+    {
+      s = reader_read_list (readchar (), a);
+      return s->car;
+    }
+
   return cons (s, reader_read_list (readchar (), a));
 }
 
-SCM
-read_env (SCM a)
+int
+index_number__ (char *s, char c)        /* Internal only */
 {
-  return reader_read_sexp_ (readchar (), a);
+  int i = 0;
+  while (s[i] != c)
+    {
+      i = i + 1;
+    }
+  return i;
 }
 
-SCM
-reader_read_block_comment (int s, int c)
+struct scm *
+set_reader__ (char *set, int mult)      /* Internal only */
 {
-  if (c == s && peekchar () == '#')
-    return readchar ();
-  return reader_read_block_comment (s, readchar ());
+  long n = 0;
+  int c = peekchar ();
+  int negative_p = 0;
+
+  if (c == '-')
+    {
+      negative_p = 1;
+      readchar ();
+      c = peekchar ();
+    }
+
+  while (in_set (c, set))
+    {
+      n = n * mult;
+      n = n + index_number__ (set, toupper (c));
+      readchar ();
+      c = peekchar ();
+    }
+
+  if (negative_p)
+    {
+      n = 0 - n;
+    }
+
+  return make_number (n);
 }
 
-SCM
-reader_read_hash (int c, SCM a)
+struct scm *
+reader_read_binary ()
+{
+  return set_reader__ ("01", 2);
+}
+
+struct scm *
+reader_read_octal ()
+{
+  return set_reader__ ("01234567", 8);
+}
+
+struct scm *
+reader_read_hex ()
+{
+  return set_reader__ ("0123456789ABCDEFabcdef", 16);
+}
+
+struct scm *reader_read_character ();
+
+struct scm *
+reader_read_hash (int c, struct scm *a)
 {
   if (c == '!')
     {
       reader_read_block_comment (c, readchar ());
       return reader_read_sexp_ (readchar (), a);
     }
+
   if (c == '|')
     {
       reader_read_block_comment (c, readchar ());
       return reader_read_sexp_ (readchar (), a);
     }
+
   if (c == 'f')
-    return cell_f;
+    {
+      return cell_f;
+    }
+
   if (c == 't')
-    return cell_t;
+    {
+      return cell_t;
+    }
+
   if (c == ',')
     {
       if (peekchar () == '@')
@@ -223,262 +325,276 @@ reader_read_hash (int c, SCM a)
 
       return cons (cell_symbol_unsyntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
     }
+
   if (c == '\'')
-    return cons (cell_symbol_syntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
+    {
+      return cons (cell_symbol_syntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
+    }
+
   if (c == '`')
-    return cons (cell_symbol_quasisyntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
+    {
+      return cons (cell_symbol_quasisyntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
+    }
+
   if (c == ':')
     {
-      SCM x = reader_read_identifier_or_number (readchar ());
-      SCM msg = MAKE_STRING0 ("keyword perifx ':' not followed by a symbol: ");
-      if (TYPE (x) == TNUMBER)
-        error (cell_symbol_system_error, cons (msg, x));
+      struct scm *x = reader_read_identifier_or_number (readchar ());
+
+      if (x->type == TNUMBER)
+        {                       /* READ error */
+          error (cell_symbol_system_error,
+                 cons (make_string_ ("keyword perifx ':' not followed by a symbol: "), x));
+        }
+
       return symbol_to_keyword (x);
     }
+
   if (c == 'b')
-    return reader_read_binary ();
+    {
+      return reader_read_binary ();
+    }
+
   if (c == 'o')
-    return reader_read_octal ();
+    {
+      return reader_read_octal ();
+    }
+
   if (c == 'x')
-    return reader_read_hex ();
+    {
+      return reader_read_hex ();
+    }
+
   if (c == '\\')
-    return reader_read_character ();
+    {
+      return reader_read_character ();
+    }
+
   if (c == '(')
-    return list_to_vector (reader_read_list (readchar (), a));
+    {
+      return list_to_vector (reader_read_list (readchar (), a));
+    }
+
   if (c == ';')
     {
       reader_read_sexp_ (readchar (), a);
       return reader_read_sexp_ (readchar (), a);
     }
+
   return reader_read_sexp_ (readchar (), a);
 }
 
-SCM
-reader_read_sexp (SCM c, SCM s, SCM a)
+struct scm *
+reader_read_sexp (struct scm *c, struct scm *a)
 {
-  return reader_read_sexp_ (VALUE (c), a);
+  struct scm *x = c;
+  return reader_read_sexp_ (x->value, a);
 }
 
-SCM
+struct scm *
 reader_read_character ()
 {
   int c = readchar ();
   int p = peekchar ();
   int i = 0;
-  if (c >= '0' && c <= '7' && p >= '0' && p <= '7')
+
+  if (in_set (c, "01234567") && in_set (p, "01234567"))
     {
       c = c - '0';
-      while (p >= '0' && p <= '7')
+
+      while (in_set (p, "01234567"))
         {
           c <<= 3;
           c += readchar () - '0';
           p = peekchar ();
         }
     }
-  else if (c == 'x' && ((p >= '0' && p <= '9') || (p >= 'a' && p <= 'f') || (p >= 'F' && p <= 'F')))
+  else if (c == 'x' && in_set (p, "01234567abcdefABCDEF"))
     {
-      c = VALUE (reader_read_hex ());
+      c = reader_read_hex ()->value;
       eputs ("reading hex c=");
       eputs (itoa (c));
       eputs ("\n");
     }
-  else if (((c >= 'a' && c <= 'z') || c == '*') && ((p >= 'a' && p <= 'z') || p == '*'))
+  else if (in_set (c, "abcdefghijklmnopqrstuvwxyz*") && in_set (p, "abcdefghijklmnopqrstuvwxyz*"))
     {
       char buf[10];
       buf[i] = c;
       i = i + 1;
-      while ((p >= 'a' && p <= 'z') || p == '*')
+
+      while (in_set (p, "abcdefghijklmnopqrstuvwxyz*"))
         {
           buf[i] = readchar ();
           i = i + 1;
           p = peekchar ();
         }
+
       buf[i] = 0;
+
       if (!strcmp (buf, "*eof*"))
-        c = EOF;
+        {
+          c = EOF;
+        }
       else if (!strcmp (buf, "nul"))
-        c = '\0';
+        {
+          c = '\0';
+        }
       else if (!strcmp (buf, "alarm"))
-        c = '\a';
+        {
+          c = '\a';
+        }
       else if (!strcmp (buf, "backspace"))
-        c = '\b';
+        {
+          c = '\b';
+        }
       else if (!strcmp (buf, "tab"))
-        c = '\t';
+        {
+          c = '\t';
+        }
       else if (!strcmp (buf, "linefeed"))
-        c = '\n';
+        {
+          c = '\n';
+        }
       else if (!strcmp (buf, "newline"))
-        c = '\n';
+        {
+          c = '\n';
+        }
       else if (!strcmp (buf, "vtab"))
-        c = '\v';
+        {
+          c = '\v';
+        }
       else if (!strcmp (buf, "page"))
-        c = '\f';
-#if 1                           //__MESC__
-      //Nyacc bug
+        {
+          c = '\f';
+        }
       else if (!strcmp (buf, "return"))
-        c = 13;
+        {
+          c = '\r';
+        }
       else if (!strcmp (buf, "esc"))
-        c = 27;
-#else
-      else if (!strcmp (buf, "return"))
-        c = '\r';
-      //Nyacc crash else if (!strcmp (buf, "esc")) c = '\e';
-#endif
+        {
+          c = '\e';
+        }
       else if (!strcmp (buf, "space"))
-        c = ' ';
-
-#if 1                           // Nyacc uses old abbrevs
+        {
+          c = ' ';
+        }
       else if (!strcmp (buf, "bel"))
-        c = '\a';
+        {
+          c = '\a';
+        }
       else if (!strcmp (buf, "bs"))
-        c = '\b';
+        {
+          c = '\b';
+        }
       else if (!strcmp (buf, "ht"))
-        c = '\t';
+        {
+          c = '\t';
+        }
       else if (!strcmp (buf, "vt"))
-        c = '\v';
-
-#if 1                           //__MESC__
-      //Nyacc bug
+        {
+          c = '\v';
+        }
       else if (!strcmp (buf, "cr"))
-        c = 13;
-#else
-      else if (!strcmp (buf, "cr"))
-        c = '\r';
-#endif
-#endif // Nyacc uses old abbrevs
-
+        {
+          c = '\r';
+        }
       else
         {
           eputs ("char not supported: ");
           eputs (buf);
           eputs ("\n");
-          error (cell_symbol_system_error, MAKE_STRING0 ("char not supported"));
+          error (cell_symbol_system_error, make_string_ ("char not supported"));
         }
     }
-  return MAKE_CHAR (c);
+
+  return make_char (c);
 }
 
-SCM
-reader_read_binary ()
+int
+escape_lookup (int c)
 {
-  long n = 0;
-  int c = peekchar ();
-  int negative_p = 0;
-  if (c == '-')
-    {
-      negative_p = 1;
-      readchar ();
-      c = peekchar ();
-    }
-  while (c == '0' || c == '1')
-    {
-      n = n << 1;
-      n = n + c - '0';
-      readchar ();
-      c = peekchar ();
-    }
-  if (negative_p)
-    n = 0 - n;
-  return MAKE_NUMBER (n);
+  if (c == '0')
+    return '\0';
+  else if (c == 'a')
+    return '\a';
+  else if (c == 'b')
+    return '\b';
+  else if (c == 't')
+    return '\t';
+  else if (c == 'n')
+    return '\n';
+  else if (c == 'v')
+    return '\v';
+  else if (c == 'f')
+    return '\f';
+  else if (c == 'r')
+    return '\r';
+  else if (c == 'e')
+    return '\e';
+  else if (c == 'x')
+    return reader_read_hex ()->value;
+  /* Any other escaped character is itself */
+  else
+    return c;
 }
 
-SCM
-reader_read_octal ()
-{
-  long n = 0;
-  int c = peekchar ();
-  int negative_p = 0;
-  if (c == '-')
-    {
-      negative_p = 1;
-      readchar ();
-      c = peekchar ();
-    }
-  while (c >= '0' && c <= '7')
-    {
-      n = n << 3;
-      n = n + c - '0';
-      readchar ();
-      c = peekchar ();
-    }
-  if (negative_p)
-    n = 0 - n;
-  return MAKE_NUMBER (n);
-}
-
-SCM
-reader_read_hex ()
-{
-  long n = 0;
-  int c = peekchar ();
-  int negative_p = 0;
-  if (c == '-')
-    {
-      negative_p = 1;
-      readchar ();
-      c = peekchar ();
-    }
-  while ((c >= '0' && c <= '9') || (c >= 'A' && c <= 'F') || (c >= 'a' && c <= 'f'))
-    {
-      n = n << 4;
-      if (c >= 'a')
-        n = n + c - 'a' + 10;
-      else if (c >= 'A')
-        n = n + c - 'A' + 10;
-      else
-        n = n + c - '0';
-      readchar ();
-      c = peekchar ();
-    }
-  if (negative_p)
-    n = 0 - n;
-  return MAKE_NUMBER (n);
-}
-
-SCM
+struct scm *
 reader_read_string ()
 {
-  size_t i = 0;
+  int i = 0;
   int c;
+
   do
     {
       if (i > MAX_STRING)
-        assert_max_string (i, "reader_read_string", g_buf);
+        {
+          assert_max_string (i, "reader_read_string", g_buf);
+        }
+
       c = readchar ();
+
       if (c == '"')
-        break;
+        {
+          break;
+        }
+
       if (c == '\\')
         {
-          c = readchar ();
-          if (c == '\\' || c == '"')
-            ;
-          else if (c == '0')
-            c = '\0';
-          else if (c == 'a')
-            c = '\a';
-          else if (c == 'b')
-            c = '\b';
-          else if (c == 't')
-            c = '\t';
-          else if (c == 'n')
-            c = '\n';
-          else if (c == 'v')
-            c = '\v';
-          else if (c == 'f')
-            c = '\f';
-          else if (c == 'r')
-            // Nyacc bug
-            // c = '\r';
-            c = 13;
-          else if (c == 'e')
-            // Nyacc bug
-            // c = '\e';
-            c = 27;
-          else if (c == 'x')
-            c = VALUE (reader_read_hex ());
+          c = escape_lookup (readchar ());
         }
+
       g_buf[i++] = c;
     }
   while (1);
+
   g_buf[i] = 0;
+  return make_string_ (g_buf);
+}
+
+struct scm *
+read_string (struct scm *port)  ///((arity . n))
+{
+  int fd = __stdin;
+  struct scm *x = port;
+
+  if (x->type == TPAIR && x->car->type == TNUMBER)
+    {
+      __stdin = x->car->value;
+    }
+
+  int c = readchar ();
+  int i = 0;
+
+  while (EOF != c)
+    {
+      assert_max_string (i, "read_string", g_buf);
+
+      g_buf[i] = c;
+      i = i + 1;
+      c = readchar ();
+    }
+
+  g_buf[i] = 0;
+  __stdin = fd;
   return make_string (g_buf, i);
 }

src/string.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,234 +22,263 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
-#include <assert.h>
-
 #include <limits.h>
 #include <string.h>
 
-long MAX_STRING;
-
-void
-assert_max_string (size_t i, char const *msg, char *string)
+int
+string_len (char *a)
 {
-  if (i > MAX_STRING)
-    {
-      eputs (msg);
-      eputs (":string too long[");
-      eputs (itoa (i));
-      eputs ("]:");
-      string[MAX_STRING - 1] = 0;
-      eputs (string);
-      error (cell_symbol_system_error, cell_f);
-    }
+  int i = 0;
+  while (0 != a[i])
+    i = i + 1;
+  return i;
 }
 
 char const *
-list_to_cstring (SCM list, size_t * size)
+list_to_cstring (struct scm *list, int *size)
 {
-  size_t i = 0;
-  char *p = g_buf;
+  int i = 0;
+
   while (list != cell_nil)
     {
-      if (i > MAX_STRING)
-        assert_max_string (i, "list_to_string", g_buf);
-      g_buf[i++] = VALUE (car (list));
-      list = cdr (list);
+      assert_max_string (i, "list_to_string", g_buf);
+
+      g_buf[i] = list->car->value;
+      i = i + 1;
+      list = list->cdr;
     }
+
   g_buf[i] = 0;
   *size = i;
   return g_buf;
 }
 
-size_t
-bytes_cells (size_t length)
+struct scm *
+make_string_ (char *s)          /* internal only */
 {
-  return (1 + sizeof (long) + sizeof (long) + length + sizeof (SCM)) / sizeof (SCM);
+  SCM l = string_len (s);
+  assert_max_string (l, "make_string_", s);
+
+  struct scm *y = make_tstring1 (l);
+  y->cdr = make_bytes (s, l);
+  return y;
 }
 
-SCM
-make_bytes (char const *s, size_t length)
+struct scm *
+make_string (char const *s, int length)
 {
-  size_t size = bytes_cells (length);
-  SCM x = alloc (size);
-  TYPE (x) = TBYTES;
-  LENGTH (x) = length;
-  char *p = (char *) &g_cells[x].cdr;
-  if (!length)
-    *(char *) p = 0;
-  else
-    memcpy (p, s, length + 1);
-  return x;
+  assert_max_string (length, "make_string", (char *) s);
+  struct scm *x = make_tstring1 (length);
+  struct scm *y = x;
+  struct scm *v = make_bytes (s, length);
+  y->cdr = v;
+  return y;
 }
 
-SCM
-make_string (char const *s, size_t length)
+struct scm *
+string_equal_p (struct scm *a, struct scm *b)
 {
-  if (length > MAX_STRING)
-    assert_max_string (length, "make_string", (char *) s);
-  SCM x = make_cell__ (TSTRING, length, 0);
-  SCM v = make_bytes (s, length);
-  CDR (x) = v;
-  return x;
-}
+  struct scm *a2 = a;
+  struct scm *b2 = b;
+  assert (a2->type == TSTRING || a2->type == TKEYWORD);
+  assert (b2->type == TSTRING || b2->type == TKEYWORD);
+  struct scm *tee = cell_t;
+  struct scm *nil = cell_f;
 
-SCM
-string_equal_p (SCM a, SCM b)   ///((name . "string=?"))
-{
-  if (!((TYPE (a) == TSTRING && TYPE (b) == TSTRING) || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
+  /* If they are the same thing */
+  if (a == b)
+    return tee;
+
+  /* If they point to the same string */
+  if (a2->cdr == b2->cdr)
+    return tee;
+
+  /*If they are both empty strings */
+  if ((NULL == a2->car) && (NULL == b2->car))
+    return tee;
+
+  /* If they are different lengths they can't be the same string */
+  if (a2->length != b2->length)
+    return nil;
+
+  /* Need to fix */
+  char *s1 = a2->cdr->string;
+  char *s2 = b2->cdr->string;
+
+  while (s1[0] == s2[0])
     {
-      eputs ("type a: ");
-      eputs (itoa (TYPE (a)));
-      eputs ("\n");
-      eputs ("type b: ");
-      eputs (itoa (TYPE (b)));
-      eputs ("\n");
-      eputs ("a= ");
-      write_error_ (a);
-      eputs ("\n");
-      eputs ("b= ");
-      write_error_ (b);
-      eputs ("\n");
-      assert ((TYPE (a) == TSTRING && TYPE (b) == TSTRING) || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD));
+      if (0 == s1[0])
+        return tee;
+      s1 = s1 + 1;
+      s2 = s2 + 1;
     }
-  if (a == b
-      || STRING (a) == STRING (b)
-      || (!LENGTH (a) && !LENGTH (b))
-      || (LENGTH (a) == LENGTH (b) && !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
-    return cell_t;
-  return cell_f;
+
+  return nil;
 }
 
-SCM
-symbol_to_string (SCM symbol)
+struct scm *
+symbol_to_string (struct scm *symbol)
 {
-  return make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
+  struct scm *a = symbol;
+  return make_tstring2 (a->car, a->cdr);
 }
 
-SCM
-symbol_to_keyword (SCM symbol)
+struct scm *
+symbol_to_keyword (struct scm *symbol)
 {
-  return make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
+  struct scm *a = symbol;
+  return make_keyword (a->car, a->cdr);
 }
 
-SCM
-keyword_to_string (SCM keyword)
+struct scm *
+make_symbol (struct scm *string)
 {
-  return make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
-}
-
-SCM
-string_to_symbol (SCM string)
-{
-  SCM x = hash_ref (g_symbols, string, cell_f);
-  if (x == cell_f)
-    x = make_symbol (string);
-  return x;
-}
-
-SCM
-make_symbol (SCM string)
-{
-  SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
+  struct scm *s = string;
+  struct scm *x = make_tsymbol (s->car, s->cdr);
   hash_set_x (g_symbols, string, x);
   return x;
 }
 
-SCM
-bytes_to_list (char const *s, size_t i)
+struct scm *
+string_to_symbol (struct scm *string)
 {
-  SCM p = cell_nil;
-  while (i--)
+  struct scm *x = hash_ref (g_symbols, string, cell_f);
+
+  if (x == cell_f)
     {
-      int c = (0x100 + s[i]) % 0x100;
-      p = cons (MAKE_CHAR (c), p);
+      x = make_symbol (string);
     }
-  return p;
+
+  return x;
 }
 
-SCM
-cstring_to_list (char const *s)
+struct scm *
+cstring_to_symbol (char *s)
 {
-  return bytes_to_list (s, strlen (s));
-}
-
-SCM
-cstring_to_symbol (char const *s)
-{
-  SCM string = MAKE_STRING0 (s);
+  struct scm *string = make_string_ (s);
   return string_to_symbol (string);
 }
 
-SCM
-string_to_list (SCM string)
+/* EXTERNAL */
+
+struct scm *
+string_equal_p_ (struct scm *a, struct scm *b)
 {
-  return bytes_to_list (CSTRING (string), LENGTH (string));
+  return string_equal_p (a, b);
 }
 
-SCM
-list_to_string (SCM list)
+struct scm *
+symbol_to_string_ (struct scm *symbol)
 {
-  size_t size;
+  return symbol_to_string (symbol);
+}
+
+struct scm *
+symbol_to_keyword_ (struct scm *symbol)
+{
+  return symbol_to_keyword (symbol);
+}
+
+struct scm *
+keyword_to_string (struct scm *keyword)
+{
+  struct scm *a = keyword;
+  return make_tstring2 (a->car, a->cdr);
+}
+
+struct scm *
+make_symbol_ (struct scm *string)
+{
+  return make_symbol (string);
+}
+
+struct scm *
+string_to_list (struct scm *string)
+{
+  struct scm *x = string;
+  char *s = x->cdr->string;
+  SCM i = string_len (s);
+  struct scm *p = cell_nil;
+
+  while (0 != i)
+    {
+      i = i - 1;
+      int c = (0xFF & s[i]);
+      p = cons (make_char (c), p);
+    }
+
+  return p;
+}
+
+struct scm *
+list_to_string (struct scm *list)
+{
+  int size;
   char const *s = list_to_cstring (list, &size);
   return make_string (s, size);
 }
 
-SCM
-read_string (SCM port)          ///((arity . n))
+void
+block_copy (void *source, void *destination, int num)
 {
-  int fd = __stdin;
-  if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
-    __stdin = VALUE (CAR (port));
-  int c = readchar ();
-  size_t i = 0;
-  while (c != -1)
+  char *s;
+  char *d = destination;
+  for (s = source; 0 < num; num = num - 1)
     {
-      if (i > MAX_STRING)
-        assert_max_string (i, "read_string", g_buf);
-      g_buf[i++] = c;
-      c = readchar ();
+      d[0] = s[0];
+      d = d + 1;
+      s = s + 1;
     }
-  g_buf[i] = 0;
-  __stdin = fd;
-  return make_string (g_buf, i);
 }
 
-SCM
-string_append (SCM x)           ///((arity . n))
+struct scm *
+string_append (struct scm *x)   /*((arity . n)) */
 {
   char *p = g_buf;
   g_buf[0] = 0;
-  size_t size = 0;
-  while (x != cell_nil)
+  int size = 0;
+  struct scm *y1 = x;
+
+  while (y1 != cell_nil)
     {
-      SCM string = CAR (x);
-      assert (TYPE (string) == TSTRING);
-      memcpy (p, CSTRING (string), LENGTH (string) + 1);
-      p += LENGTH (string);
-      size += LENGTH (string);
-      if (size > MAX_STRING)
-        assert_max_string (size, "string_append", g_buf);
-      x = CDR (x);
+      struct scm *y2 = y1->car;
+      assert (y2->type == TSTRING);
+      memcpy (p, y2->cdr->string, y2->rac + 1);
+      p += y2->length;
+      size += y2->length;
+
+      assert_max_string (size, "string_append", g_buf);
+
+      y1 = y1->cdr;
     }
+
   return make_string (g_buf, size);
 }
 
-SCM
-string_length (SCM string)
+struct scm *
+string_length (struct scm *string)
 {
-  assert (TYPE (string) == TSTRING);
-  return MAKE_NUMBER (LENGTH (string));
+  struct scm *x = string;
+  assert (x->type == TSTRING);
+  return make_number (x->length);
 }
 
-SCM
-string_ref (SCM str, SCM k)
+struct scm *
+string_ref (struct scm *str, struct scm *k)
 {
-  assert (TYPE (str) == TSTRING);
-  assert (TYPE (k) == TNUMBER);
-  size_t size = LENGTH (str);
-  size_t i = VALUE (k);
+  struct scm *x = str;
+  struct scm *y = k;
+  assert (x->type == TSTRING);
+  assert (y->type == TNUMBER);
+  size_t size = x->length;
+  size_t i = y->value;
+
   if (i > size)
-    error (cell_symbol_system_error, cons (MAKE_STRING0 ("value out of range"), k));
-  char const *p = CSTRING (str);
-  return MAKE_CHAR (p[i]);
+    {
+      error (cell_symbol_system_error,
+             cons (make_string ("value out of range", string_len ("value out of range")), k));
+    }
+
+  char *p = x->cdr->string;
+  return make_char (p[i]);
 }

src/struct.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,68 +22,62 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
-#include <assert.h>
-
-SCM
-make_struct (SCM type, SCM fields, SCM printer)
+struct scm *
+struct_length (struct scm *x)
 {
-  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++)
+  assert (x->type == TSTRUCT);
+  return make_number (x->length);
+}
+
+struct scm *
+struct_ref_ (struct scm *x, long i)
+{
+  assert (x->type == TSTRUCT);
+  assert (i < x->length);
+  struct scm *f = x->cdr + i;
+
+  if (f->type == TREF)
     {
-      SCM e = cell_unspecified;
-      if (fields != cell_nil)
-        {
-          e = CAR (fields);
-          fields = CDR (fields);
-        }
-      g_cells[v + i] = g_cells[vector_entry (e)];
+      return f->car;
     }
-  return x;
+
+  if (f->type == TCHAR)
+    {
+      return make_char (f->value);
+    }
+
+  if (f->type == TNUMBER)
+    {
+      return make_number (f->value);
+    }
+
+  return f;
 }
 
-SCM
-struct_length (SCM x)
+struct scm *
+struct_set_x_ (struct scm *x, long i, struct scm *e)
 {
-  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 (i < LENGTH (x));
-  g_cells[STRUCT (x) + i] = g_cells[vector_entry (e)];
+  assert (x->type == TSTRUCT);
+  assert (i < x->length);
+  struct scm *v = vector_entry (e);
+  struct scm *y = x->cdr + i;
+  /* The below is likely going to be a problem for M2-Planet until we add pointer dereferencing */
+  *y = *v;
   return cell_unspecified;
 }
 
-SCM
-struct_ref (SCM x, SCM i)
+struct scm *
+struct_ref (struct scm *x, struct scm *i)       /* External */
 {
-  return struct_ref_ (x, VALUE (i));
+  struct scm *h = i;
+  struct scm *y = x;
+  return struct_ref_ (y, h->value);
 }
 
-SCM
-struct_set_x (SCM x, SCM i, SCM e)
+struct scm *
+struct_set_x (struct scm *x, struct scm *i, struct scm *e)
 {
-  return struct_set_x_ (x, VALUE (i), e);
+  struct scm *h = i;
+  struct scm *y = x;
+  return struct_set_x_ (y, h->value, e);
 }

src/vector.c

@@ -1,6 +1,7 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2019 Jeremiah Orians <jeremiah@pdp10.guru>
  *
  * This file is part of GNU Mes.
  *
@@ -21,99 +22,170 @@
 #include "mes/lib.h"
 #include "mes/mes.h"
 
-#include <assert.h>
-
-SCM
-make_vector__ (long k)
+struct scm *
+make_vector_ (struct scm *n)
 {
-  SCM v = alloc (k);
-  SCM x = make_cell__ (TVECTOR, k, v);
-  for (long i = 0; i < k; i++)
-    g_cells[v + i] = g_cells[vector_entry (cell_unspecified)];
-  return x;
+  struct scm *m = n;
+  return make_vector__ (m->cdr);
 }
 
-SCM
-make_vector_ (SCM n)
+struct scm *
+vector_length (struct scm *x)
 {
-  return make_vector__ (VALUE (n));
+  assert (x->type == TVECTOR);
+  return make_number (x->length);
 }
 
-SCM
-vector_length (SCM x)
+struct scm *
+vector_ref_ (struct scm *table, long i)
 {
-  assert (TYPE (x) == TVECTOR);
-  return MAKE_NUMBER (LENGTH (x));
-}
+  struct scm *y = table;
+  assert (y->type == TVECTOR);
+  assert (i < y->length);
+  struct scm *e = y->cdr + i;
+
+  if (e->type == TREF)
+    {
+      return e->car;
+    }
 
-SCM
-vector_ref_ (SCM x, long i)
-{
-  assert (TYPE (x) == TVECTOR);
-  assert (i < LENGTH (x));
-  SCM e = VECTOR (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
-vector_ref (SCM x, SCM i)
+struct scm *
+vector_equal_p (struct scm *a, struct scm *b)
 {
-  return vector_ref_ (x, VALUE (i));
+  struct scm *a2 = a;
+  struct scm *b2 = b;
+
+  if (a2->length != b2->length)
+    {
+      return cell_f;
+    }
+
+  SCM i;
+  for (i = 0; i < a2->length; i = i + 1)
+    {
+      struct scm *ai = a2->vector + i;
+      struct scm *ai2 = ai;
+      struct scm *bi = b2->vector + i;
+      struct scm *bi2 = bi;
+
+      if (ai2->type == TREF)
+        {
+          ai = ai2->car;
+        }
+
+      if (bi2->type == TREF)
+        {
+          bi = bi2->car;
+        }
+
+      if (equal2_p (ai, bi) == cell_f)
+        {
+          return cell_f;
+        }
+    }
+  return cell_t;
 }
 
-SCM
-vector_entry (SCM x)
+struct scm *
+vector_ref (struct scm *x, struct scm *i)
 {
-  if (TYPE (x) != TCHAR && TYPE (x) != TNUMBER)
-    x = MAKE_REF (x);
-  return x;
+  assert (x->type == TVECTOR);
+  assert (i->value < x->length);
+  struct scm *e = x->cdr + i->value;
+
+  if (e->type == TREF)
+    {
+      return e->car;
+    }
+
+  return e;
 }
 
-SCM
-vector_set_x_ (SCM x, long i, SCM e)
+struct scm *
+vector_entry (struct scm *x)
 {
-  assert (TYPE (x) == TVECTOR);
-  assert (i < LENGTH (x));
-  g_cells[VECTOR (x) + i] = g_cells[vector_entry (e)];
+  if (TCHAR == x->type)
+    {
+      return x;
+    }
+
+  if (TNUMBER == x->type)
+    {
+      return x;
+    }
+
+  return make_tref (x);
+}
+
+void
+vector_set_x_ (struct scm *x, long i, struct scm *e)
+{
+  assert (x->type == TVECTOR);
+  assert (i < x->length);
+  struct scm *z = x->cdr + i;
+  struct scm *f = vector_entry (e);
+
+  z->type = f->type;
+  z->car = f->car;
+  z->cdr = f->cdr;
+}
+
+struct scm *
+vector_set_x (struct scm *x)
+{
+  SCM i = x->cdr->car->value;
+  assert (x->car->type == TVECTOR);
+  assert (i < x->car->length);
+  struct scm *z = x->car->cdr + (i * CELL_SIZE);
+  struct scm *f = vector_entry (x->cdr->cdr->car);
+
+  z->type = f->type;
+  z->car = f->car;
+  z->cdr = f->cdr;
   return cell_unspecified;
 }
 
-SCM
-vector_set_x (SCM x, SCM i, SCM e)
+struct scm *
+list_to_vector (struct scm *x)
 {
-  return vector_set_x_ (x, VALUE (i), e);
-}
+  struct scm *v = make_vector__ (length__ (x));
+  struct scm *y = x;
+  struct scm *p = v->cdr;
+  struct scm *z;
 
-SCM
-list_to_vector (SCM x)
-{
-
-  SCM v = make_vector__ (length__ (x));
-  SCM p = VECTOR (v);
-  while (x != cell_nil)
+  while (y != cell_nil)
     {
-      g_cells[p++] = g_cells[vector_entry (car (x))];
-      x = cdr (x);
+      z = vector_entry (y->car);
+      p->type = z->type;
+      p->car = z->car;
+      p->cdr = z->cdr;
+      p = p + 1;
+      y = y->cdr;
     }
+
   return v;
 }
 
-SCM
-vector_to_list (SCM v)
+struct scm *
+vector_to_list (struct scm *v)
 {
-  SCM x = cell_nil;
-  for (long i = LENGTH (v); i; i--)
+  struct scm *x = cell_nil;
+  SCM i;
+
+  for (i = v->length; i; i = i - 1)
     {
-      SCM e = VECTOR (v) + i - 1;
-      if (TYPE (e) == TREF)
-        e = REF (e);
-      x = cons (e, x);
+      struct scm *f = v->cdr + i - 1;
+
+      if (f->type == TREF)
+        {
+          f = f->car;
+        }
+
+      x = cons (f, x);
     }
+
   return x;
 }