mescc: Posixify interface.
authorJan Nieuwenhuizen <janneke@gnu.org>
Fri, 25 May 2018 06:05:02 +0000 (08:05 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Fri, 25 May 2018 06:05:02 +0000 (08:05 +0200)
* module/mescc/compile.mes: Move from language/c99/compiler.mes.
* module/mescc: New module..
* module/mescc/M1.scm: Move from mes/M1.mes.
* module/mescc/as.scm: Likewise.
* module/mescc/bytevectors.scm: Likewise.
* module/mescc/mescc.scm: New file.
* scripts/mescc: Update to new layout and posixy interface.
* GNUmakefile: Likewise.
* build-aux/build-cc.sh: Likewise.
* build-aux/build-guile.sh: Likewise.
* build-aux/build-mes.sh: Likewise.
* build-aux/build-mlibc.sh: Likewise.
* build-aux/cc-mes.sh: Likewise.
* build-aux/cc-mlibc.sh: Likewise.
* build-aux/cc.sh: Likewise.
* build-aux/check-mescc.sh: Likewise.
* build-aux/test.sh: Likewise.
* build.sh: Likewise.
* .gitignore: Update for posixy extensions.

68 files changed:
.gitignore
AUTHORS
GNUmakefile
build-aux/build-cc.sh
build-aux/build-guile.sh
build-aux/build-mes.sh
build-aux/build-mlibc.sh
build-aux/cc-mes.sh
build-aux/cc-mlibc.sh
build-aux/cc.sh
build-aux/check-boot.sh
build-aux/check-mescc.sh
build-aux/compile-all.scm [deleted file]
build-aux/test.sh
build.sh
check.sh
guile/mescc [new symlink]
lib/libc-gcc.c
lib/libc-mes.c
lib/libc-mini-gcc.c [new file with mode: 0644]
lib/libc-mini-mes.c [new file with mode: 0644]
lib/libc-mini.c [new file with mode: 0644]
lib/linux-mini-gcc.c [new file with mode: 0644]
lib/linux-mini-mes.c [new file with mode: 0644]
lib/mini-libc-gcc.c [deleted file]
lib/mini-libc-mes.c [deleted file]
lib/mini-libc.c [deleted file]
lib/mini-linux-gcc.c [deleted file]
lib/mini-linux-mes.c [deleted file]
module/language/c99/compiler.mes [deleted file]
module/language/c99/compiler.scm [deleted file]
module/language/c99/info.mes [deleted file]
module/language/c99/info.scm [deleted file]
module/mes/M1.mes [deleted file]
module/mes/M1.scm [deleted file]
module/mes/as-i386.mes [deleted file]
module/mes/as-i386.scm [deleted file]
module/mes/as.mes [deleted file]
module/mes/as.scm [deleted file]
module/mes/boot-0.scm
module/mes/bytevectors.mes [deleted file]
module/mes/bytevectors.scm [deleted file]
module/mes/elf.mes [deleted file]
module/mes/elf.scm [deleted file]
module/mes/guile.mes
module/mes/mescc.mes [new file with mode: 0644]
module/mes/misc.mes [new file with mode: 0644]
module/mes/misc.scm [new file with mode: 0644]
module/mes/posix.mes
module/mescc/M1.mes [new file with mode: 0644]
module/mescc/M1.scm [new file with mode: 0644]
module/mescc/as.mes [new file with mode: 0644]
module/mescc/as.scm [new file with mode: 0644]
module/mescc/bytevectors.mes [new file with mode: 0644]
module/mescc/bytevectors.scm [new file with mode: 0644]
module/mescc/compile.mes [new file with mode: 0644]
module/mescc/compile.scm [new file with mode: 0644]
module/mescc/i386/as.mes [new file with mode: 0644]
module/mescc/i386/as.scm [new file with mode: 0644]
module/mescc/info.mes [new file with mode: 0644]
module/mescc/info.scm [new file with mode: 0644]
module/mescc/mescc.mes [new file with mode: 0644]
module/mescc/mescc.scm [new file with mode: 0644]
module/mescc/preprocess.mes [new file with mode: 0644]
module/mescc/preprocess.scm [new file with mode: 0644]
module/srfi/srfi-1.mes
module/srfi/srfi-13.mes
scripts/mescc

index 29fc9994e7e47e6e7e9be8ff534f6fea5443bb13..72179c1366cad0e496c60fe0d7b1a6dd57cb50a0 100644 (file)
@@ -8,12 +8,13 @@
 *.0-guile
 *.0-hex2
 *.E
-*.M1
+*.S
+*.o
+*.blood-elf
 *.gcc
 *.guile
-*.hex2
-*.hex2-o
 *.log
+*.gcc-o
 *.mes-o
 *.mes-stdout
 *.mini-M1
@@ -32,8 +33,8 @@
 
 /src/*.h
 /src/*.i
+/src/mes
 
-*.o
 /.config.make
 /.store
 /.tarball-version
@@ -59,4 +60,3 @@
 /doc/fosdem/fosdem.tex
 /doc/fosdem/fosdem.toc
 /doc/fosdem/fosdem.*vrb
-
diff --git a/AUTHORS b/AUTHORS
index 757e0f40b7fc9f59cb11752e8ca9576dc1f7ad0a..c3f0bcd9d8a375a97010bc08ae9caaad702290be 100644 (file)
--- a/AUTHORS
+++ b/AUTHORS
@@ -12,9 +12,6 @@ List of imported files
 Based on Guile ECMAScript
 module/language/c/lexer.mes
 
-Included verbatim from GNU Guix
-build-aux/compile-all.scm
-
 Included verbatim from gnulib
 build-aux/gitlog-to-changelog
 
index ba7196efe627daa76e78523a0639444819a9447d..820b27295cc968f673afaa66d8cd662225c16262 100644 (file)
@@ -38,7 +38,7 @@ install:
 
 .config.make: ./configure
 
-seed:
+seed: all-go
        cd $(MES_SEED) && git reset --hard HEAD
        MES=$(GUILE) GUILE=$(GUILE) SEED=1 build-aux/build-mes.sh
        cd $(MES_SEED) && MES_PREFIX=$(PWD) ./refresh.sh
index b147c001035f354ff511ffda3d55ace2ed8a01a5..0672c07ab385790328e5d4d04ebda47529a7fd3f 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -ex
+set -e
+
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
 
 export CC CFLAGS CPPFLAGS
 
@@ -46,7 +50,7 @@ build-aux/mes-snarf.scm src/posix.c
 build-aux/mes-snarf.scm src/reader.c
 build-aux/mes-snarf.scm src/vector.c
 
-NOLINK=1 sh build-aux/cc.sh lib/mini-libc-gcc
+NOLINK=1 sh build-aux/cc.sh lib/libc-mini-gcc
 NOLINK=1 sh build-aux/cc.sh lib/libc-gcc
 NOLINK=1 sh build-aux/cc.sh lib/libc+tcc-gcc
 
index 00834fbcfa5472dbfd3a766ededfb27d12180b2a..75e826ccea3d7b04856b912db46de3c49784fc04 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -ex
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
 
 export GUILE
 GUILE=${GUILE-$(command -v guile)}
+GUILE_TOOLS=${GUILE_TOOLS-$(command -v guile-tools)}
+
+set -e
 
 SCM_FILES="
-language/c99/compiler.scm
-language/c99/info.scm
-mes/as-i386.scm
-mes/as.scm
-mes/bytevectors.scm
-mes/elf.scm
-mes/guile.scm
-mes/test.scm
-mes/M1.scm"
+guile/mes/guile.scm
+guile/mes/misc.scm
+guile/mes/test.scm
+guile/mescc/M1.scm
+guile/mescc/as.scm
+guile/mescc/bytevectors.scm
+guile/mescc/compile.scm
+guile/mescc/i386/as.scm
+guile/mescc/info.scm
+guile/mescc/mescc.scm
+guile/mescc/preprocess.scm
+"
 
 export srcdir=.
 export host=$($GUILE -c "(display %host-type)")
-cd guile
-$GUILE --no-auto-compile -L . -C . -s ../build-aux/compile-all.scm $SCM_FILES
+
+#$GUILE --no-auto-compile -L guile -C guile -s build-aux/compile-all.scm $SCM_FILES
+
+for i in $SCM_FILES; do
+    go=${i%%.scm}.go
+    if [ $i -nt $go ]; then
+        echo "  GUILEC $i"
+        $GUILE_TOOLS compile -L guile -L scripts -o $go $i
+    fi
+done
+
+SCRIPTS="
+scripts/mescc
+"
+
+for i in $SCRIPTS; do
+    go=${i%%.scm}.go
+    if [ $i -nt $go ]; then
+        echo "  GUILEC $i"
+        $GUILE_TOOLS compile -L guile -L scripts -o $go $i
+    fi
+done
index 1bfac16ecd772be439097284c13973199a8bb8df..5ed839617d1697622931c74b2c911824199e8fa5 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -x
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
 
 export BLOOD_ELF GUILE HEX2 M1 MES MESCC
 export M1FLAGS HEX2FLAGS PREPROCESS
 export MES_SEED MES_ARENA
 
+GUILE=${GUILE-guile}
+if [ -z "$GUILE" -o "$GUILE" = "true" ] || ! command -v $GUILE > /dev/null; then
+    GUILE=src/mes
+fi
+
 HEX2=${HEX2-hex2}
 M1=${M1-M1}
 BLOOD_ELF=${BLOOD_ELF-blood-elf}
@@ -50,55 +57,58 @@ if [ -d "$MES_SEED" ]; then
         $M1FLAGS\
         -f stage0/x86.M1\
         -f $MES_SEED/crt1.M1\
-        -o lib/crt1.hex2
+        -o lib/crt1.o
     $M1\
         $M1FLAGS\
         -f stage0/x86.M1\
         -f $MES_SEED/libc-mes.M1\
-        -o lib/libc-mes.hex2
+        -o lib/libc-mes.o
     $M1\
         --LittleEndian\
         --Architecture=1\
         -f stage0/x86.M1\
         -f $MES_SEED/mes.M1\
-        -o src/mes.hex2
+        -o src/mes.o
     $BLOOD_ELF\
         -f stage0/x86.M1\
         -f $MES_SEED/mes.M1\
         -f $MES_SEED/libc-mes.M1\
-        -o src/mes.blood-elf.M1
+        -o src/mes.S.blood-elf
     $M1\
         --LittleEndian\
         --Architecture=1\
-        -f src/mes.blood-elf.M1\
-        -o src/mes.blood-elf.hex2
+        -f src/mes.S.blood-elf\
+        -o src/mes.o.blood-elf
     $HEX2\
         $HEX2FLAGS\
         -f stage0/elf32-header.hex2\
-        -f lib/crt1.hex2\
-        -f lib/libc-mes.hex2\
-        -f src/mes.hex2\
-        -f src/mes.blood-elf.hex2\
+        -f lib/crt1.o\
+        -f lib/libc-mes.o\
+        -f src/mes.o\
+        -f src/mes.o.blood-elf\
         --exec_enable\
         -o src/mes.seed-out
     cp src/mes.seed-out src/mes
-
     $M1\
         $M1FLAGS\
         -f stage0/x86.M1\
         -f $MES_SEED/libc+tcc-mes.M1\
-        -o src/libc+tcc-mes.hex2
+        -o lib/libc+tcc-mes.o
 fi
 
 PREPROCESS=1
 NOLINK=1 sh build-aux/cc-mes.sh lib/crt1
-NOLINK=1 sh build-aux/cc-mes.sh lib/mini-libc-mes
+NOLINK=1 sh build-aux/cc-mes.sh lib/libc-mini-mes
 NOLINK=1 sh build-aux/cc-mes.sh lib/libc-mes
 NOLINK=1 sh build-aux/cc-mes.sh lib/libc+tcc-mes
 
+cp lib/crt1.mes-o lib/crt1.o
+cp lib/libc-mini-mes.mes-o lib/libc-mini-mes.o
+cp lib/libc-mes.mes-o lib/libc-mes.o
+cp lib/libc+tcc-mes.mes-o lib/libc+tcc-mes.o
+
 [ -n "$SEED" ] && exit 0
 
-GUILE=src/mes
 MES_ARENA=${MES_ARENA-30000000}
 sh build-aux/mes-snarf.scm --mes src/gc.c
 sh build-aux/mes-snarf.scm --mes src/lib.c
@@ -108,10 +118,10 @@ sh build-aux/mes-snarf.scm --mes src/posix.c
 sh build-aux/mes-snarf.scm --mes src/reader.c
 sh build-aux/mes-snarf.scm --mes src/vector.c
 
-sh build-aux/cc-mes.sh scaffold/main
-sh build-aux/cc-mes.sh scaffold/hello
-sh build-aux/cc-mes.sh scaffold/argv
-sh build-aux/cc-mes.sh scaffold/malloc
+sh build-aux/cc-mes.sh scaffold/main
+sh build-aux/cc-mes.sh scaffold/hello
+sh build-aux/cc-mes.sh scaffold/argv
+sh build-aux/cc-mes.sh scaffold/malloc
 ##sh build-aux/cc-mes.sh scaffold/micro-mes
 ##sh build-aux/cc-mes.sh scaffold/tiny-mes
 # sh build-aux/cc-mes.sh scaffold/mini-mes
index 1739cf638ffe8d10077a603814bb9079fe677442..5b2a2150f0f9e9f5dcf35be4e128540249371097 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -ex
+set -e
+
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
 
 export CC32 CPPFLAGS C32FLAGS
 
@@ -59,7 +63,7 @@ C32FLAGS=${C32FLAGS-"
 "}
 
 NOLINK=1 sh build-aux/cc-mlibc.sh lib/crt1
-NOLINK=1 sh build-aux/cc-mlibc.sh lib/mini-libc-gcc
+NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-mini-gcc
 NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-gcc
 NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc+tcc-gcc
 
index 5836ddb6afead3e99b456fafa1310bfa0c859ecd..d1dad87127da909e820a7ee22b77c05b726d5bdd 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -x
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
 
 export BLOOD_ELF GUILE HEX2 M1 MES MESCC
 export M1FLAGS HEX2FLAGS PREPROCESS
-export MES_SEED MES_ARENA
 
 HEX2=${HEX2-hex2}
 M1=${M1-M1}
 BLOOD_ELF=${BLOOD_ELF-blood-elf}
-MES_SEED=${MES_SEED-../mes-seed}
 MESCC=${MESCC-$(command -v mescc)}
 [ -z "$MESCC" ] && MESCC=scripts/mescc
 MES=${MES-$(command -v mes)}
@@ -41,67 +41,32 @@ CPPFLAGS=${CPPFLAGS-"
 -I lib
 -I include
 "}
-
-MESCCLAGS=${MESCCFLAGS-"
-"}
-LIBC=${LIBC-lib/libc}
-M1FLAGS=${M1FLAGS-"
---LittleEndian
---Architecture=1
-"}
-HEX2FLAGS=${HEX2FLAGS-"
---LittleEndian
---Architecture=1
---BaseAddress=0x1000000
+MESCCFLAGS=${MESCCFLAGS-"
 "}
 
+if [ -n "$BUILD_DEBUG" ]; then
+    MESCCFLAGS="$MESCCFLAGS -v"
+fi
+
 c=$1
 
 set -e
 
 if [ -n "$PREPROCESS" ]; then
-    sh -x $MESCC\
-       -E\
-       $CPPFLAGS\
-       $MESCCFLAGS\
-       -o "$c".E\
-       "$c".c
-    sh -x $MESCC\
-       -c\
-       -o "$c".M1\
-       "$c".E
+    sh $MESCC $MESCCFLAGS $CPPFLAGS -E "$c".c
+    sh $MESCC $MESCCFLAGS -S "$c".E
+    sh $MESCC $MESCCFLAGS -c -o "$c".mes-o "$c".S
+    if [ -z "$NOLINK" ]; then
+        sh $MESCC $MESCCFLAGS -o "$c".mes-out "$c".mes-o $MESCCLIBS
+    fi
+elif [ -n "$COMPILE" ]; then
+    sh $MESCC $MESCCFLAGS $CPPFLAGS -S "$c".c
+    sh $MESCC $MESCCFLAGS -c -o "$c".mes-o "$c".S
+    if [ -z "$NOLINK" ]; then
+        sh $MESCC $MESCCFLAGS -o "$c".mes-out "$c".mes-o $MESCCLIBS
+    fi
+elif [ -z "$NOLINK" ]; then
+    sh $MESCC $MESCCFLAGS $CPPFLAGS -o "$c".mes-out "$c".c $MESCCLIBS
 else
-    sh -x $MESCC\
-       -c\
-       $CPPFLAGS\
-       $MESCCFLAGS\
-       -o "$c".M1\
-       "$c".c
-fi
-
-$M1\
-    $M1FLAGS\
-    -f stage0/x86.M1\
-    -f "$c".M1\
-    -o "$c".hex2
-
-if [ -z "$NOLINK" ]; then
-    $BLOOD_ELF\
-        -f stage0/x86.M1\
-        -f "$c".M1\
-        -f $LIBC-mes.M1\
-        -o "$c".blood-elf-M1
-    $M1\
-        $M1FLAGS\
-        -f "$c".blood-elf-M1\
-        -o "$c".blood-elf-hex2
-    $HEX2\
-        $HEX2FLAGS\
-        -f stage0/elf32-header.hex2\
-        -f lib/crt1.hex2\
-        -f $LIBC-mes.hex2\
-        -f "$c".hex2\
-        -f "$c".blood-elf-hex2\
-        --exec_enable\
-        -o "$c".mes-out
+    sh $MESCC $MESCCFLAGS $CPPFLAGS -c -o "$c".mes-out "$c".c
 fi
index 4c8190f1aeb12be0e855a490b5f11276168b1f59..985db1b4903c922b95529890efd02c4ed9faab86 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -ex
+set -e
+
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
 
 CPPFLAGS=${CPPFLAGS-"
 -D VERSION=\"$VERSION\"
@@ -56,5 +60,6 @@ if [ -z "$NOLINK" ]; then
         -o "$c".mlibc-out\
         lib/crt1.mlibc-o\
         "$c".mlibc-o\
-        $LIBC-gcc.mlibc-o
+        $LIBC-gcc.mlibc-o\
+        $CC32LIBS
 fi
index 0929a2051adfb8e4590023d30b73c5286b67a937..b85ed2d5778b33956b13255aa720980caa836104 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -ex
+set -e
+
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
 
 CPPFLAGS=${CPPFLAGS-"
 -D VERSION=\"$VERSION\"
index f418c935d97548014e61146e82589222c835d286..34844314d357a956824bc264fc46071b402b692c 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -e
 
 export GUILE MES
-GUILE=${GUILE-guile}
 MES=${MES-./src/mes}
 
+GUILE=${GUILE-guile}
+if ! command -v $GUILE > /dev/null; then
+    GUILE=true
+fi
+
+set -e
+
 tests="
 
 00-zero.scm
index dbf65fb28d7a667041fa0ccfd4d9d5c66ff51987..4546cda0889fea13891649dcc29be8119c78f551 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
+
 export BLOOD_ELF GUILE HEX2 M1 MES MESCC
-export M1FLAGS HEX2FLAGS PREPROCESS LIBC
+export M1FLAGS HEX2FLAGS PREPROCESS
 export MES_ARENA MES_PREFIX MES_SEED
+export BUILD_DEBUG
+export CC32LIBS MESCCLIBS
 
 MES=${MES-src/mes}
 MESCC=${MESCC-scripts/mescc}
@@ -36,6 +42,9 @@ MESCC=${MESCC-$(command -v mescc)}
 MES=${MES-$(command -v mes)}
 [ -z "$MES" ] && MES=src/mes
 
+if ! command -v $GUILE > /dev/null; then
+    GUILE=true
+fi
 
 tests="
 t
@@ -135,14 +144,18 @@ expect=$(echo $broken | wc -w)
 pass=0
 fail=0
 total=0
+MESCCLIBS=
 LIBC=libc/libc
 for t in $tests; do
     if [ -z "${t/[012][0-9]-*/}" ]; then
-        LIBC=lib/mini-libc;
+        LIBC="lib/libc-mini"
+        MESCCLIBS="-l c-mini"
     elif [ -z "${t/8[0-9]-*/}" ]; then
-        LIBC=lib/libc+tcc;
+        LIBC="lib/libc+tcc"
+        MESCCLIBS="-l c+tcc"
     else
-        LIBC=lib/libc;
+        LIBC=libc/libc
+        MESCCLIBS=
     fi
     sh build-aux/test.sh "scaffold/tests/$t" &> scaffold/tests/"$t".log
     r=$?
diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm
deleted file mode 100644 (file)
index 013904b..0000000
+++ /dev/null
@@ -1,159 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix 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 Guix 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 Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(use-modules (system base target)
-             (system base message)
-             (ice-9 match)
-             (ice-9 threads))
-
-(define (mkdir-p dir)
-  "Create directory DIR and all its ancestors."
-  (define absolute?
-    (string-prefix? "/" dir))
-
-  (define not-slash
-    (char-set-complement (char-set #\/)))
-
-  (let loop ((components (string-tokenize dir not-slash))
-             (root       (if absolute?
-                             ""
-                             ".")))
-    (match components
-      ((head tail ...)
-       (let ((path (string-append root "/" head)))
-         (catch 'system-error
-           (lambda ()
-             (mkdir path)
-             (loop tail path))
-           (lambda args
-             (if (= EEXIST (system-error-errno args))
-                 (loop tail path)
-                 (apply throw args))))))
-      (() #t))))
-
-(define warnings
-  '(unsupported-warning format unbound-variable arity-mismatch))
-
-(define host (getenv "host"))
-
-(define srcdir (getenv "srcdir"))
-
-(define (relative-file file)
-  (if (string-prefix? (string-append srcdir "/") file)
-      (string-drop file (+ 1 (string-length srcdir)))
-      file))
-
-(define (file-mtime<? f1 f2)
-  (< (stat:mtime (stat f1))
-     (stat:mtime (stat f2))))
-
-(define (scm->go file)
-  (let* ((relative (relative-file file))
-         (without-extension (string-drop-right relative 4)))
-    (string-append without-extension ".go")))
-
-(define (scm->mes file)
-  (let ((base (string-drop-right file 4)))
-    (string-append base ".mes")))
-
-(define (file-needs-compilation? file)
-  (let ((go (scm->go file)))
-    (or (not (file-exists? go))
-        (file-mtime<? go file)
-        (let ((mes (scm->mes file))) ; FIXME: try to respect (include-from-path ".mes")
-          (and (file-exists? mes)
-               (file-mtime<? go mes))))))
-
-(define (file->module file)
-  (let* ((relative (relative-file file))
-         (module-path (string-drop-right relative 4)))
-    (map string->symbol
-         (string-split module-path #\/))))
-
-;;; To work around <http://bugs.gnu.org/15602> (FIXME), we want to load all
-;;; files to be compiled first.  We do this via resolve-interface so that the
-;;; top-level of each file (module) is only executed once.
-(define (load-module-file file)
-  (let ((module (file->module file)))
-    (format #t "  LOAD     ~a~%" module)
-    (resolve-interface module)))
-
-(cond-expand
- (guile-2.2 (use-modules (language tree-il optimize)
-                         (language cps optimize)))
- (else #f))
-
-(define %default-optimizations
-  ;; Default optimization options (equivalent to -O2 on Guile 2.2).
-  (cond-expand
-   (guile-2.2 (append (tree-il-default-optimization-options)
-                      (cps-default-optimization-options)))
-    (else '())))
-
-(define %lightweight-optimizations
-  ;; Lightweight optimizations (like -O0, but with partial evaluation).
-  (let loop ((opts %default-optimizations)
-             (result '()))
-    (match opts
-      (() (reverse result))
-      ((#:partial-eval? _ rest ...)
-       (loop rest `(#t #:partial-eval? ,@result)))
-      ((kw _ rest ...)
-       (loop rest `(#f ,kw ,@result))))))
-
-(define (optimization-options file)
-  (if (string-contains file "gnu/packages/")
-      %lightweight-optimizations                  ;build faster
-      '()))
-
-(define (compile-file* file output-mutex)
-  (let ((go (scm->go file)))
-    (with-mutex output-mutex
-      (format #t "  GUILEC   ~a~%" go)
-      (force-output))
-    (mkdir-p (dirname go))
-    (with-fluids ((*current-warning-prefix* ""))
-      (with-target host
-        (lambda ()
-          (compile-file file
-                        #:output-file go
-                        #:opts `(#:warnings ,warnings
-                                 ,@(optimization-options file))))))))
-
-;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
-;; opportunity to run upon SIGINT and to remove temporary output files.
-(sigaction SIGINT
-  (lambda args
-    (exit 1)))
-
-(match (command-line)
-  ((_ . files)
-   (let ((files (filter file-needs-compilation? files)))
-     (for-each load-module-file files)
-     (let ((mutex (make-mutex)))
-       ;; Make sure compilation related modules are loaded before starting to
-       ;; compile files in parallel.
-       (compile #f)
-       (par-for-each (lambda (file)
-                       (compile-file* file mutex))
-                     files)))))
-
-;;; Local Variables:
-;;; eval: (put 'with-target 'scheme-indent-function 1)
-;;; End:
index 5908f7bc16ce461eba6f804041b68fbff742c087..d8ae6e7a5ed2d1ffba744c58f5bb09cca46907a2 100755 (executable)
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -x
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
 
-export LIBC
+export LIBC MESCCLIBS
 
 GUILE=${GUILE-$MES}
 DIFF=${DIFF-$(command -v diff)}
index 2e2525eaf386948517680134bc60c13abb05218b..f5f89d01be4462319a172ab9207d7e84e7916fad 100755 (executable)
--- a/build.sh
+++ b/build.sh
 # You should have received a copy of the GNU General Public License
 # along with Mes.  If not, see <http://www.gnu.org/licenses/>.
 
-set -x
+if [ -n "$BUILD_DEBUG" ]; then
+    set -x
+fi
+
 # dash does not export foo=${foo-bar} for some values
 export CC CC32 GUILE MESCC MES_SEED
 export MES_ARENA MES_DEBUG
 export PREFIX DATADIR MODULEDIR
 export CPPFLAGS CFLAGS C32FLAGS MESCCFLAGS
+export BUILD_DEBUG
 
 CC=${CC-$(command -v gcc)}
 CC32=${CC32-$(command -v i686-unknown-linux-gnu-gcc)}
@@ -31,7 +35,7 @@ MESCC=${MESCC-$(command -v mescc)}
 MES_SEED=${MES_SEED-../mes-seed}
 GUILE=${GUILE-$(command -v guile)}
 MES_ARENA=${MES_ARENA-300000000}
-MES_DEBUG=${MES_DEBUG-2}
+MES_DEBUG=${MES_DEBUG-1}
 
 PREFIX=${PREFIX-/usr/local}
 DATADIR=${DATADIR-$PREFIX/share/mes}
index 9c8b2fab34ff3353ab22cbe6449082ee39daae4e..ce659332295d5bbd8afecef5e39d2ebe70fb2a12 100755 (executable)
--- a/check.sh
+++ b/check.sh
 
 export CC32
 export GUILE MES MES_ARENA
+export BUILD_DEBUG
+
 CC32=${CC32-$(command -v i686-unknown-linux-gnu-gcc)}
 GUILE=${GUILE-guile}
 MES=${MES-src/mes}
-MES_ARENA=${MES_ARENA-100000000}
+MES_ARENA=${MES_ARENA-300000000}
+PREFIX=
+
+if ! command -v $GUILE > /dev/null; then
+    GUILE=true
+fi
 
 set -e
 bash build-aux/check-boot.sh
diff --git a/guile/mescc b/guile/mescc
new file mode 120000 (symlink)
index 0000000..540fb2d
--- /dev/null
@@ -0,0 +1 @@
+../module/mescc
\ No newline at end of file
index b69489f08c3d1946ae4da15bc487fbf06047939c..1bcc0a7caf3117e090f74aef9baa7a3b77993b81 100644 (file)
@@ -29,8 +29,8 @@
 #include <fcntl.h>
 #include <assert.h>
 
-#include <mini-linux-gcc.c>
-#include <mini-libc.c>
+#include <linux-mini-gcc.c>
+#include <libc-mini.c>
 #include <linux-gcc.c>
 #include <libc.c>
 
index 92136b0c5116530ac152ad59abc62ffc77f8c992..91fde8b23b7525db1b47b2aebb64d40bf74c404c 100644 (file)
@@ -25,7 +25,7 @@
 
 void _env ();
 
-#include <mini-linux-mes.c>
-#include <mini-libc.c>
+#include <linux-mini-mes.c>
+#include <libc-mini.c>
 #include <linux-mes.c>
 #include <libc.c>
diff --git a/lib/libc-mini-gcc.c b/lib/libc-mini-gcc.c
new file mode 100644 (file)
index 0000000..5eff7e5
--- /dev/null
@@ -0,0 +1,22 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ *
+ * This file is part of Mes.
+ *
+ * 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.
+ *
+ * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <linux-mini-gcc.c>
+#include <libc-mini.c>
diff --git a/lib/libc-mini-mes.c b/lib/libc-mini-mes.c
new file mode 100644 (file)
index 0000000..bc1eadd
--- /dev/null
@@ -0,0 +1,22 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ *
+ * This file is part of Mes.
+ *
+ * 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.
+ *
+ * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <linux-mini-mes.c>
+#include <libc-mini.c>
diff --git a/lib/libc-mini.c b/lib/libc-mini.c
new file mode 100644 (file)
index 0000000..23b0725
--- /dev/null
@@ -0,0 +1,49 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ *
+ * This file is part of Mes.
+ *
+ * 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.
+ *
+ * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef __MES_SIZE_T
+#define __MES_SIZE_T
+#undef size_t
+typedef unsigned long size_t;
+#endif
+
+size_t
+strlen (char const* s)
+{
+  int i = 0;
+  while (s[i]) i++;
+  return i;
+}
+
+int
+eputs (char const* s)
+{
+  int i = strlen (s);
+  write (2, s, i);
+  return 0;
+}
+
+int
+puts (char const* s)
+{
+  int i = strlen (s);
+  write (1, s, i);
+  return 0;
+}
diff --git a/lib/linux-mini-gcc.c b/lib/linux-mini-gcc.c
new file mode 100644 (file)
index 0000000..e6914b3
--- /dev/null
@@ -0,0 +1,83 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ *
+ * This file is part of Mes.
+ *
+ * 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.
+ *
+ * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#if !POSIX
+
+void
+exit (int code)
+{
+#if !__TINYC__
+  asm (
+       "mov    %0,%%ebx\n\t"
+       "mov    $1,%%eax\n\t"
+       "int    $0x80\n\t"
+       : // no outputs "=" (r)
+       : "" (code)
+       );
+#else // __TINYC__
+  asm (
+       "mov    %0,%%ebx\n\t"
+       "mov    $1,%%eax\n\t"
+       "int    $128\n\t"
+       : // no outputs "=" (r)
+       : "Ir" (code)
+       );
+#endif // __TINYC__
+  // not reached
+  exit (0);
+}
+
+int
+write (int fd, char const* s, int n)
+{
+  int r;
+#if __GNUC__
+  asm (
+       "mov    %1,%%ebx\n\t"
+       "mov    %2,%%ecx\n\t"
+       "mov    %3,%%edx\n\t"
+
+       "mov    $0x04,%%eax\n\t"
+       "int    $0x80\n\t"
+       "mov    %%eax,%0\n\t"
+       : "=r" (r)
+       : "" (fd), "" (s), "" (n)
+       : "eax", "ebx", "ecx", "edx"
+       );
+
+  //syscall (SYS_write, fd, s, n));
+#elif __TINYC__
+  asm (
+       "mov    %1,%%ebx\n\t"
+       "mov    %2,%%ecx\n\t"
+       "mov    %3,%%edx\n\t"
+
+       "mov    $4, %%eax\n\t"
+       "int    $128\n\t"
+       "mov    %%eax,%0\n\t"
+       : "=r" (r)
+       : "Ir" (fd), "Ir" (s), "Ir" (n)
+       : "eax", "ebx", "ecx"//, "edx"
+       );
+#endif
+  return r;
+}
+
+#endif //!POSIX
diff --git a/lib/linux-mini-mes.c b/lib/linux-mini-mes.c
new file mode 100644 (file)
index 0000000..95ba971
--- /dev/null
@@ -0,0 +1,39 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ *
+ * This file is part of Mes.
+ *
+ * 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.
+ *
+ * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+void
+exit ()
+{
+  asm ("mov____0x8(%ebp),%ebx !8");
+
+  asm ("mov____$i32,%eax SYS_exit");
+  asm ("int____$0x80");
+}
+
+void
+write ()
+{
+  asm ("mov____0x8(%ebp),%ebx !8");
+  asm ("mov____0x8(%ebp),%ecx !12");
+  asm ("mov____0x8(%ebp),%edx !16");
+
+  asm ("mov____$i32,%eax SYS_write");
+  asm ("int____$0x80");
+}
diff --git a/lib/mini-libc-gcc.c b/lib/mini-libc-gcc.c
deleted file mode 100644 (file)
index 2702168..0000000
+++ /dev/null
@@ -1,22 +0,0 @@
-/* -*-comment-start: "//";comment-end:""-*-
- * Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
- *
- * This file is part of Mes.
- *
- * 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.
- *
- * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
- */
-
-#include <mini-linux-gcc.c>
-#include <mini-libc.c>
diff --git a/lib/mini-libc-mes.c b/lib/mini-libc-mes.c
deleted file mode 100644 (file)
index 5aa1b85..0000000
+++ /dev/null
@@ -1,22 +0,0 @@
-/* -*-comment-start: "//";comment-end:""-*-
- * Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
- *
- * This file is part of Mes.
- *
- * 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.
- *
- * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
- */
-
-#include <mini-linux-mes.c>
-#include <mini-libc.c>
diff --git a/lib/mini-libc.c b/lib/mini-libc.c
deleted file mode 100644 (file)
index 23b0725..0000000
+++ /dev/null
@@ -1,49 +0,0 @@
-/* -*-comment-start: "//";comment-end:""-*-
- * Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
- *
- * This file is part of Mes.
- *
- * 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.
- *
- * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
- */
-
-#ifndef __MES_SIZE_T
-#define __MES_SIZE_T
-#undef size_t
-typedef unsigned long size_t;
-#endif
-
-size_t
-strlen (char const* s)
-{
-  int i = 0;
-  while (s[i]) i++;
-  return i;
-}
-
-int
-eputs (char const* s)
-{
-  int i = strlen (s);
-  write (2, s, i);
-  return 0;
-}
-
-int
-puts (char const* s)
-{
-  int i = strlen (s);
-  write (1, s, i);
-  return 0;
-}
diff --git a/lib/mini-linux-gcc.c b/lib/mini-linux-gcc.c
deleted file mode 100644 (file)
index e6914b3..0000000
+++ /dev/null
@@ -1,83 +0,0 @@
-/* -*-comment-start: "//";comment-end:""-*-
- * Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
- *
- * This file is part of Mes.
- *
- * 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.
- *
- * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
- */
-
-#if !POSIX
-
-void
-exit (int code)
-{
-#if !__TINYC__
-  asm (
-       "mov    %0,%%ebx\n\t"
-       "mov    $1,%%eax\n\t"
-       "int    $0x80\n\t"
-       : // no outputs "=" (r)
-       : "" (code)
-       );
-#else // __TINYC__
-  asm (
-       "mov    %0,%%ebx\n\t"
-       "mov    $1,%%eax\n\t"
-       "int    $128\n\t"
-       : // no outputs "=" (r)
-       : "Ir" (code)
-       );
-#endif // __TINYC__
-  // not reached
-  exit (0);
-}
-
-int
-write (int fd, char const* s, int n)
-{
-  int r;
-#if __GNUC__
-  asm (
-       "mov    %1,%%ebx\n\t"
-       "mov    %2,%%ecx\n\t"
-       "mov    %3,%%edx\n\t"
-
-       "mov    $0x04,%%eax\n\t"
-       "int    $0x80\n\t"
-       "mov    %%eax,%0\n\t"
-       : "=r" (r)
-       : "" (fd), "" (s), "" (n)
-       : "eax", "ebx", "ecx", "edx"
-       );
-
-  //syscall (SYS_write, fd, s, n));
-#elif __TINYC__
-  asm (
-       "mov    %1,%%ebx\n\t"
-       "mov    %2,%%ecx\n\t"
-       "mov    %3,%%edx\n\t"
-
-       "mov    $4, %%eax\n\t"
-       "int    $128\n\t"
-       "mov    %%eax,%0\n\t"
-       : "=r" (r)
-       : "Ir" (fd), "Ir" (s), "Ir" (n)
-       : "eax", "ebx", "ecx"//, "edx"
-       );
-#endif
-  return r;
-}
-
-#endif //!POSIX
diff --git a/lib/mini-linux-mes.c b/lib/mini-linux-mes.c
deleted file mode 100644 (file)
index 95ba971..0000000
+++ /dev/null
@@ -1,39 +0,0 @@
-/* -*-comment-start: "//";comment-end:""-*-
- * Mes --- Maxwell Equations of Software
- * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
- *
- * This file is part of Mes.
- *
- * 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.
- *
- * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
- */
-
-void
-exit ()
-{
-  asm ("mov____0x8(%ebp),%ebx !8");
-
-  asm ("mov____$i32,%eax SYS_exit");
-  asm ("int____$0x80");
-}
-
-void
-write ()
-{
-  asm ("mov____0x8(%ebp),%ebx !8");
-  asm ("mov____0x8(%ebp),%ecx !12");
-  asm ("mov____0x8(%ebp),%edx !16");
-
-  asm ("mov____$i32,%eax SYS_write");
-  asm ("int____$0x80");
-}
diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes
deleted file mode 100644 (file)
index 7af6c89..0000000
+++ /dev/null
@@ -1,2527 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; compiler.mes produces an i386 binary from the C produced by
-;;; Nyacc c99.
-
-;;; Code:
-
-(cond-expand
- (guile-2)
- (guile)
- (mes
-  (mes-use-module (srfi srfi-1))
-  (mes-use-module (srfi srfi-26))
-  (mes-use-module (mes pmatch))
-  (mes-use-module (nyacc lang c99 parser))
-  (mes-use-module (nyacc lang c99 pprint))
-  (mes-use-module (mes as))
-  (mes-use-module (mes as-i386))
-  (mes-use-module (mes M1))
-  (mes-use-module (mes optargs))
-  (mes-use-module (language c99 info))))
-
-(define (logf port string . rest)
-  (apply format (cons* port string rest))
-  (force-output port)
-  #t)
-
-(define (stderr string . rest)
-  (apply logf (cons* (current-error-port) string rest)))
-
-(define (pke . stuff)
-  (newline (current-error-port))
-  (display ";;; " (current-error-port))
-  (write stuff (current-error-port))
-  (newline (current-error-port))
-  (car (last-pair stuff)))
-
-(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "PREFIX") "") "@PREFIX@"))
-
-(define mes? (pair? (current-module)))
-
-(define %int-size 4)
-(define %pointer-size %int-size)
-
-(define* (c99-input->full-ast #:key (defines '()) (includes '()))
-  (let ((sys-include (if (equal? %prefix "") "include" (string-append %prefix "/share/include"))))
-    (parse-c99
-     #:inc-dirs (append includes (cons* sys-include "include" "lib" (or (and=> (getenv "C_INCLUDE_PATH") (cut string-split <> #\:)) '())))
-     #:cpp-defs `(
-                  "NULL=0"
-                  "__linux__=1"
-                  "__i386__=1"
-                  "POSIX=0"
-                  "_POSIX_SOURCE=0"
-                  "__MESC__=1"
-                  ,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
-                  ,@defines)
-     #:mode 'code)))
-
-(define (ast-strip-comment o)
-  (pmatch o
-    ((comment . ,comment) #f)
-    (((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
-    (((comment . ,comment) . ,cdr) cdr)
-    ((,car . (comment . ,comment)) car)
-    ((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
-                   (cons (ast-strip-comment h) (ast-strip-comment t))))
-    (_  o)))
-
-(define (ast-strip-const o)
-  (pmatch o
-    ((type-qual ,qual) (if (equal? qual "const") #f o))
-    ((pointer (type-qual-list (type-qual ,qual)) . ,rest)
-     (if (equal? qual "const") `(pointer ,@rest) o))
-    ((decl-spec-list (type-qual ,qual))
-     (if (equal? qual "const") #f
-         `(decl-spec-list (type-qual ,qual))))
-    ((decl-spec-list (type-qual ,qual) . ,rest)
-     (if (equal? qual "const") `(decl-spec-list ,@rest)
-         `(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
-    ((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
-     (if (equal? qual "const") `(decl-spec-list ,@rest)
-         `(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
-    ((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
-                   (cons (ast-strip-const h) (ast-strip-const t))))
-    (_  o)))
-
-(define (clone o . rest)
-  (cond ((info? o)
-         (let ((types (.types o))
-               (constants (.constants o))
-               (functions (.functions o))
-               (globals (.globals o))
-               (locals (.locals o))
-               (statics (.statics o))
-               (function (.function o))
-               (text (.text o))
-               (post (.post o))
-               (break (.break o))
-               (continue (.continue o)))
-           (let-keywords rest
-                         #f
-                         ((types types)
-                          (constants constants)
-                          (functions functions)
-                          (globals globals)
-                          (locals locals)
-                          (statics statics)
-                          (function function)
-                          (text text)
-                          (post post)
-                          (break break)
-                          (continue continue))
-                         (make <info> #:types types #:constants constants #:functions functions #:globals globals  #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue))))))
-
-(define (ident->constant name value)
-  (cons name value))
-
-(define (enum->type-entry name fields)
-  (cons `(tag ,name) (make-type 'enum 4 fields)))
-
-(define (struct->type-entry name fields)
-  (let ((size (apply + (map (compose ->size cdr) fields))))
-    (cons `(tag ,name) (make-type 'struct size fields))))
-
-(define (union->type-entry name fields)
-  (let ((size (apply max (map (compose ->size cdr) fields))))
-    (cons `(tag ,name) (make-type 'union size fields))))
-
-(define i386:type-alist
-  `(("char" . ,(make-type 'signed 1 #f))
-    ("short" . ,(make-type 'signed 2 #f))
-    ("int" . ,(make-type 'signed 4 #f))
-    ("long" . ,(make-type 'signed 4 #f))
-    ("default" . ,(make-type 'signed 4 #f))
-    ;;("long long" . ,(make-type 'signed 8 #f))
-    ;;("long long int" . ,(make-type 'signed 8 #f))
-
-    ("long long" . ,(make-type 'signed 4 #f))  ;; FIXME
-    ("long long int" . ,(make-type 'signed 4 #f))
-
-    ("void" . ,(make-type 'void 1 #f))
-    ;; FIXME sign
-    ("unsigned char" . ,(make-type 'unsigned 1 #f))
-    ("unsigned short" . ,(make-type 'unsigned 2 #f))
-    ("unsigned short int" . ,(make-type 'unsigned 2 #f))
-    ("unsigned" . ,(make-type 'unsigned 4 #f))
-    ("unsigned int" . ,(make-type 'unsigned 4 #f))
-    ("unsigned long" . ,(make-type 'unsigned 4 #f))
-
-    ;; ("unsigned long long" . ,(make-type 'builtin 8 #f))
-    ;; ("unsigned long long int" . ,(make-type 'builtin 8 #f))
-    ("unsigned long long" . ,(make-type 'unsigned 4 #f)) ;; FIXME
-    ("unsigned long long int" . ,(make-type 'unsigned 4 #f))
-
-    ("float" . ,(make-type 'float 4 #f))
-    ("double" . ,(make-type 'float 8 #f))
-    ("long double" . ,(make-type 'float 16 #f))))
-
-(define (signed? o)
-  (eq? ((compose type:type ->type) o) 'signed))
-
-(define (unsigned? o)
-  (eq? ((compose type:type ->type) o) 'unsigned))
-
-(define (->size o)
-  (cond ((and (type? o) (eq? (type:type o) 'union))
-         (apply max (map (compose ->size cdr) (struct->fields o))))
-        ((type? o) (type:size o))
-        ((pointer? o) %pointer-size)
-        ((c-array? o) (* (c-array:count o) ((compose ->size c-array:type) o)))
-        ((local? o) ((compose ->size local:type) o))
-        ((global? o) ((compose ->size global:type) o))
-        ((bit-field? o) ((compose ->size bit-field:type) o))
-        ((and (pair? o) (pair? (car o)) (bit-field? (cdar o))) ((compose ->size cdar) o))
-        ;; FIXME
-        ;; (#t
-        ;;  (stderr "o=~s\n" o)
-        ;;  (format (current-error-port) "->size: not a <type>: ~s\n" o)
-        ;;  4)
-        (else (error "->size>: not a <type>:" o))))
-
-(define (ast->type o info)
-  (define (type-helper o info)
-    (if (getenv "MESC_DEBUG")
-        (stderr "type-helper: ~s\n" o))
-    (pmatch o
-      (,t (guard (type? t)) t)
-      (,p (guard (pointer? p)) p)
-      (,a (guard (c-array? a)) a)
-      (,b (guard (bit-field? b)) b)
-
-      ((char ,value) (get-type "char" info))
-      ((enum-ref . _) (get-type "default" info))
-      ((fixed ,value) (get-type "default" info))
-      ((float ,float) (get-type "float" info))
-      ((void) (get-type "void" info))
-
-      ((ident ,name) (ident->type info name))
-      ((tag ,name) (or (get-type o info)
-                       o))
-
-      (,name (guard (string? name))
-             (let ((type (get-type name info)))
-               (ast->type type info)))
-
-      ((type-name (decl-spec-list ,type) (abs-declr (pointer . ,pointer)))
-       (let ((rank (pointer->rank `(pointer ,@pointer)))
-             (type (ast->type type info)))
-         (rank+= type rank)))
-
-      ((type-name ,type) (ast->type type info))
-      ((type-spec ,type) (ast->type type info))
-
-      ((sizeof-expr ,expr) (ast->type expr info))
-      ((sizeof-type ,type) (ast->type type info))
-
-      ((string ,string) (make-c-array (get-type "char" info) (1+ (string-length string))))
-
-      ((decl-spec-list (type-spec ,type)) (ast->type type info))
-
-      ((fctn-call (p-expr (ident ,name)) . _)
-       (or (and=> (assoc-ref (.functions info) name) function:type)
-           (get-type "default" info)))
-
-      ((fctn-call (de-ref (p-expr (ident ,name))) . _)
-       (or (and=> (assoc-ref (.functions info) name) function:type)
-           (get-type "default" info)))
-
-      ((fixed-type ,type) (ast->type type info))
-      ((float-type ,type) (ast->type type info))
-      ((type-spec ,type) (ast->type type info))
-      ((typename ,type) (ast->type type info))
-
-      ((array-ref ,index ,array) (rank-- (ast->type array info)))
-
-      ((de-ref ,expr) (rank-- (ast->type expr info)))
-      ((ref-to ,expr) (rank++ (ast->type expr info)))
-
-      ((p-expr ,expr) (ast->type expr info))
-      ((pre-inc ,expr) (ast->type expr info))
-      ((post-inc ,expr) (ast->type expr info))
-
-      ((struct-ref (ident ,type))
-       (or (get-type type info)
-           (let ((struct (if (pair? type) type `(tag ,type))))
-             (ast->type struct info))))
-      ((union-ref (ident ,type))
-       (or (get-type type info)
-           (let ((struct (if (pair? type) type `(tag ,type))))
-             (ast->type struct info))))
-
-      ((struct-def (ident ,name) . _)
-       (ast->type `(tag ,name) info))
-      ((union-def (ident ,name) . _)
-       (ast->type `(tag ,name) info))
-      ((struct-def (field-list . ,fields))
-       (let ((fields (append-map (struct-field info) fields)))
-         (make-type 'struct (apply + (map field:size fields)) fields)))
-      ((union-def (field-list . ,fields))
-       (let ((fields (append-map (struct-field info) fields)))
-         (make-type 'union (apply + (map field:size fields)) fields)))
-      ((enum-def (enum-def-list . ,fields))
-       (get-type "default" info))
-
-      ((d-sel (ident ,field) ,struct)
-       (let ((type0 (ast->type struct info)))
-         (ast->type (field-type info type0 field) info)))
-
-      ((i-sel (ident ,field) ,struct)
-       (let ((type0 (ast->type (rank-- (ast->type struct info)) info)))
-         (ast->type (field-type info type0 field) info)))
-
-      ;; arithmetic
-      ((pre-inc ,a) (ast->type a info))
-      ((pre-dec ,a) (ast->type a info))
-      ((post-inc ,a) (ast->type a info))
-      ((post-dec ,a) (ast->type a info))
-      ((add ,a ,b) (ast->type a info))
-      ((sub ,a ,b) (ast->type a info))
-      ((bitwise-and ,a ,b) (ast->type a info))
-      ((bitwise-not ,a) (ast->type a info))
-      ((bitwise-or ,a ,b) (ast->type a info))
-      ((bitwise-xor ,a ,b) (ast->type a info))
-      ((lshift ,a ,b) (ast->type a info))
-      ((rshift ,a ,b) (ast->type a info))
-      ((div ,a ,b) (ast->type a info))
-      ((mod ,a ,b) (ast->type a info))
-      ((mul ,a ,b) (ast->type a info))
-      ((not ,a) (ast->type a info))
-      ((neg ,a) (ast->type a info))
-      ((eq ,a ,b) (ast->type a info))
-      ((ge ,a ,b) (ast->type a info))
-      ((gt ,a ,b) (ast->type a info))
-      ((ne ,a ,b) (ast->type a info))
-      ((le ,a ,b) (ast->type a info))
-      ((lt ,a ,b) (ast->type a info))
-
-      ;; logical
-      ((or ,a ,b) (ast->type a info))
-      ((and ,a ,b) (ast->type a info))
-
-      ((cast (type-name ,type) ,expr) (ast->type type info))
-
-      ((cast (type-name ,type (abs-declr ,pointer)) ,expr)
-       (let ((rank (pointer->rank pointer)))
-         (rank+= (ast->type type info) rank)))
-
-      ((decl-spec-list (type-spec ,type)) (ast->type type info))
-
-      ;;  ;; `typedef int size; void foo (unsigned size u)
-      ((decl-spec-list (type-spec ,type) (type-spec ,type2))
-       (ast->type type info))
-
-      ((assn-expr ,a ,op ,b) (ast->type a info))
-
-      ((cond-expr _ ,a ,b) (ast->type a info))
-
-      (_ (get-type o info))))
-
-  (let ((type (type-helper o info)))
-    (cond ((or (type? type)
-               (pointer? type) type
-               (c-array? type)) type)
-          ((and (equal? type o) (pair? type) (eq? (car type) 'tag)) o)
-          ((equal? type o)
-           (error "ast->type: not supported: " o))
-          (else (ast->type type info)))))
-
-(define (ast->basic-type o info)
-  (let ((type (->type (ast->type o info))))
-    (cond ((type? type) type)
-          ((equal? type o) o)
-          (else (ast->type type info)))))
-
-(define (get-type o info)
-  (let ((t (assoc-ref (.types info) o)))
-    (pmatch t
-      ((typedef ,next) (or (get-type next info) o))
-      (_ t))))
-
-
-(define (ast-type->size info o)
-  (let ((type (->type (ast->type o info))))
-    (cond ((type? type) (type:size type))
-          (else (stderr "ast-type->size barf: ~s => ~s\n" o type)
-                4))))
-
-(define (field:name o)
-  (pmatch o
-    ((struct (,name ,type ,size ,pointer) . ,rest) name)
-    ((union (,name ,type ,size ,pointer) . ,rest) name)
-    ((,name . ,type) name)
-    (_ (error "field:name not supported:" o))))
-
-(define (field:pointer o)
-  (pmatch o
-    ((struct (,name ,type ,size ,pointer) . ,rest) pointer)
-    ((union (,name ,type ,size ,pointer) . ,rest) pointer)
-    ((,name . ,type) (->rank type))
-    (_ (error "field:pointer not supported:" o))))
-
-(define (field:size o)
-  (pmatch o
-    ((struct . ,type) (apply + (map field:size (struct->fields type))))
-    ((union . ,type) (apply max (map field:size (struct->fields type))))
-    ((,name . ,type) (->size type))
-    (_ (error (format #f "field:size: ~s\n" o)))))
-
-(define (field-field info struct field)
-  (let ((fields (type:description struct)))
-    (let loop ((fields fields))
-      (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
-          (let ((f (car fields)))
-            (cond ((equal? (car f) field) f)
-                  ((and (memq (car f) '(struct union)) (type? (cdr f))
-                        (find (lambda (x) (equal? (car x) field)) (struct->fields (cdr f)))))
-                  ((eq? (car f) 'bits) (assoc field (cdr f)))
-                  (else (loop (cdr fields)))))))))
-
-(define (field-offset info struct field)
-  (if (eq? (type:type struct) 'union) 0
-      (let ((fields (type:description struct)))
-        (let loop ((fields fields) (offset 0))
-          (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
-              (let ((f (car fields)))
-                (cond ((equal? (car f) field) offset)
-                      ((and (eq? (car f) 'struct) (type? (cdr f)))
-                       (let ((fields (type:description (cdr f))))
-                         (find (lambda (x) (equal? (car x) field)) fields)
-                         (apply + (cons offset
-                                        (map field:size
-                                             (member field (reverse fields)
-                                                     (lambda (a b)
-                                                       (equal? a (car b) field))))))))
-                      ((and (eq? (car f) 'union) (type? (cdr f))
-                            (let ((fields (struct->fields (cdr f))))
-                              (and (find (lambda (x) (equal? (car x) field)) fields)
-                                   offset))))
-                      ((and (eq? (car f) 'bits) (assoc-ref (cdr f) field)) offset)
-                      (else (loop (cdr fields) (+ offset (field:size f)))))))))))
-
-(define (field-pointer info struct field)
-  (let ((field (field-field info struct field)))
-    (field:pointer field)))
-
-(define (field-size info struct field)
-  (if (eq? (type:type struct) 'union) 0
-      (let ((field (field-field info struct field)))
-        (field:size field))))
-
-(define (field-size info struct field)
-  (let ((field (field-field info struct field)))
-    (field:size field)))
-
-(define (field-type info struct field)
-  (let ((field (field-field info struct field)))
-    (ast->type (cdr field) info)))
-
-(define (struct->fields o)
-  (pmatch o
-    (_ (guard (and (type? o) (eq? (type:type o) 'struct)))
-       (append-map struct->fields (type:description o)))
-    (_ (guard (and (type? o) (eq? (type:type o) 'union)))
-       (append-map struct->fields (type:description o)))
-    ((struct . ,type) (list (car (type:description type))))
-    ((union . ,type) (list (car (type:description type))))
-    ((bits . ,bits) bits)
-    (_ (list o))))
-
-(define (struct->init-fields o)
-  (pmatch o
-    (_ (guard (and (type? o) (eq? (type:type o) 'struct)))
-       (append-map struct->init-fields (type:description o)))
-    (_ (guard (and (type? o) (eq? (type:type o) 'union)))
-       (append-map struct->init-fields (type:description o)))
-    ((struct . ,type) (struct->init-fields type))
-    ((union . ,type) (list (car (type:description type))))
-    (_ (list o))))
-
-(define (byte->hex.m1 o)
-  (string-drop o 2))
-
-(define (asm->m1 o)
-  (let ((prefix ".byte "))
-    (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
-        (let ((s (string-drop o (string-length prefix))))
-          (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
-
-(define (ident->variable info o)
-  (or (assoc-ref (.locals info) o)
-      (assoc-ref (.statics info) o)
-      (assoc-ref (filter (negate static-global?) (.globals info)) o)
-      (assoc-ref (.constants info) o)
-      (assoc-ref (.functions info) o)
-      (begin
-        (error "ident->variable: undefined variable:" o))))
-
-(define (static-global? o)
-  ((compose global:function cdr) o))
-
-(define (string-global? o)
-  (and (pair? (car o))
-       (eq? (caar o) #:string)))
-
-(define (ident->type info o)
-  (let ((var (ident->variable info o)))
-    (cond ((global? var) (global:type var))
-          ((local? var) (local:type var))
-          ((function? var) (function:type var))
-          ((assoc-ref (.constants info) o) (assoc-ref (.types info) "default"))
-          ((pair? var) (car var))
-          (else (stderr "ident->type ~s => ~s\n" o var)
-                #f))))
-
-(define (local:pointer o)
-  (->rank o))
-
-(define (ident->rank info o)
-  (->rank (ident->variable info o)))
-
-(define (ident->size info o)
-  ((compose type:size (cut ident->type info <>)) o))
-
-(define (pointer->rank o)
-  (pmatch o
-    ((pointer) 1)
-    ((pointer ,pointer) (1+ (pointer->rank pointer)))))
-
-(define (expr->rank info o)
-  (->rank (ast->type o info)))
-
-(define (ast->size o info)
-  (->size (ast->type o info)))
-
-(define (append-text info text)
-  (clone info #:text (append (.text info) text)))
-
-(define (push-global info)
-  (lambda (o)
-    (let ((rank (ident->rank info o)))
-      (cond ((< rank 0) (list (i386:push-label `(#:address ,o)))) ;; FIXME
-            (else (list (i386:push-label-mem `(#:address ,o))))))))
-
-(define (push-local locals)
-  (lambda (o)
-    (wrap-as (i386:push-local (local:id o)))))
-
-(define (push-global-address info)
-  (lambda (o)
-    (list (i386:push-label o))))
-
-(define (push-local-address locals)
-  (lambda (o)
-    (wrap-as (i386:push-local-address (local:id o)))))
-
-(define (push-local-de-ref info)
-  (lambda (o)
-    (let ((size (->size o)))
-      (case size
-        ((1) (wrap-as (i386:push-byte-local-de-ref (local:id o))))
-        ((2) (wrap-as (i386:push-word-local-de-ref (local:id o))))
-        ((4) (wrap-as (i386:push-local-de-ref (local:id o))))
-        (else (error (format #f "TODO: push size >4: ~a\n" size)))))))
-
- ;; (if (= ptr 2) (ast-type->size info (local:type o)) ;; URG
- ;;                       4)
-(define (push-local-de-de-ref info)
-  (lambda (o)
-    (let ((size (->size (rank-- (rank-- o)))))
-      (if (= size 1)
-          (wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
-          (error "TODO int-de-de-ref")))))
-
-(define (make-global-entry name type value)
-  (cons name (make-global name type value #f)))
-
-(define (string->global-entry string)
-  (let ((value (append (string->list string) (list #\nul))))
-   (make-global-entry `(#:string ,string) "char" value))) ;; FIXME char-array
-
-(define (make-local-entry name type id)
-  (cons name (make-local name type id)))
-
-(define* (mescc:trace name #:optional (type ""))
-  (format (current-error-port) "    :~a~a\n" name type))
-
-(define (push-ident info)
-  (lambda (o)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (push-local (.locals info)))
-          ((assoc-ref (.statics info) o)
-           =>
-           (push-global info))
-          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
-           =>
-           (push-global info))
-          ((assoc-ref (.constants info) o)
-           =>
-           (lambda (constant)
-             (wrap-as (append (i386:value->accu constant)
-                              (i386:push-accu)))))
-          (else
-           ((push-global-address #f) `(#:address ,o))))))
-
-(define (push-ident-address info)
-  (lambda (o)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (push-local-address (.locals info)))
-          ((assoc-ref (.statics info) o)
-           =>
-           (push-global-address info))
-          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
-           =>
-           (push-global-address info))
-          (else
-           ((push-global-address #f) `(#:address ,o))))))
-
-(define (push-ident-de-ref info)
-  (lambda (o)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (push-local-de-ref info))
-          (else ((push-global info) o)))))
-
-(define (push-ident-de-de-ref info)
-  (lambda (o)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (push-local-de-de-ref info))
-          (else
-           (error "not supported: global push-ident-de-de-ref:" o)))))
-
-(define (expr->arg info)
-  (lambda (o)
-    (pmatch o
-      ((p-expr (string ,string))
-       (let* ((globals ((globals:add-string (.globals info)) string))
-              (info (clone info #:globals globals)))
-         (append-text info ((push-global-address info) `(#:string ,string)))))
-      (_ (let ((info (expr->accu o info)))
-           (append-text info (wrap-as (i386:push-accu))))))))
-
-(define (globals:add-string globals)
-  (lambda (o)
-    (let ((string `(#:string ,o)))
-      (if (assoc-ref globals string) globals
-          (append globals (list (string->global-entry o)))))))
-
-(define (ident->accu info)
-  (lambda (o)
-    (cond ((assoc-ref (.locals info) o) => local->accu)
-          ((assoc-ref (.statics info) o) => global->accu)
-          ((assoc-ref (filter (negate static-global?) (.globals info)) o) => global->accu)
-          ((assoc-ref (.constants info) o) => number->accu)
-          (else (list (i386:label->accu `(#:address ,o)))))))
-
-(define (local->accu o)
-  (let* ((type (local:type o)))
-    (cond ((or (c-array? type)
-               (structured-type? type)) (wrap-as (i386:local-ptr->accu (local:id o))))
-          (else (append (wrap-as (i386:local->accu (local:id o)))
-                        (convert-accu type))))))
-
-(define (global->accu o)
-  (let ((type (global:type o)))
-    (cond ((or (c-array? type)
-               (structured-type? type)) (wrap-as (i386:label->accu `(#:address ,o))))
-          (else (append (wrap-as (i386:label-mem->accu `(#:address ,o)))
-                        (convert-accu type))))))
-
-(define (number->accu o)
-  (wrap-as (i386:value->accu o)))
-
-(define (ident-address->accu info)
-  (lambda (o)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (lambda (local) (wrap-as (i386:local-ptr->accu (local:id local)))))
-          ((assoc-ref (.statics info) o)
-           =>
-           (lambda (global) (list (i386:label->accu `(#:address ,global)))))
-          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
-           =>
-           (lambda (global) (list (i386:label->accu `(#:address ,global)))))
-          (else (list (i386:label->accu `(#:address ,o)))))))
-
-(define (ident-address->base info)
-  (lambda (o)
-    (cond
-     ((assoc-ref (.locals info) o)
-      =>
-      (lambda (local) (wrap-as (i386:local-ptr->base (local:id local)))))
-     ((assoc-ref (.statics info) o)
-      =>
-      (lambda (global) (list (i386:label->base `(#:address ,global)))))
-     ((assoc-ref (filter (negate static-global?) (.globals info)) o)
-      =>
-      (lambda (global) (list (i386:label->base `(#:address ,global)))))
-     (else (list (i386:label->base `(#:address ,o)))))))
-
-(define (value->accu v)
-  (wrap-as (i386:value->accu v)))
-
-(define (accu->local+n-text local n)
-  (let ((id (local:id local))) (wrap-as (i386:accu->local+n id n))))
-
-(define (accu->ident info)
-  (lambda (o)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (lambda (local) (let ((size (->size local)))
-                             (if (<= size 4) (wrap-as (i386:accu->local (local:id local)))
-                                 (wrap-as (i386:accu*n->local (local:id local) size))))))
-          ((assoc-ref (.statics info) o)
-           =>
-           (lambda (global) (let ((size (->size global)))
-                              (if (<= size 4) (wrap-as (i386:accu->label global))
-                                  (wrap-as (i386:accu*n->label global size))))))
-          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
-           =>
-           (lambda (global) (let ((size (->size global)))
-                              (if (<= size 4) (wrap-as (i386:accu->label global))
-                                  (wrap-as (i386:accu*n->label global size)))))))))
-
-(define (value->ident info)
-  (lambda (o value)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (lambda (local) (wrap-as (i386:value->local (local:id local) value))))
-          ((assoc-ref (.statics info) o)
-           =>
-           (lambda (global) (list (i386:value->label `(#:address ,global) value))))
-          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
-           =>
-           (lambda (global) (list (i386:value->label `(#:address ,global) value)))))))
-
-(define (ident-add info)
-  (lambda (o n)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (lambda (local) (wrap-as (i386:local-add (local:id local) n))))
-          ((assoc-ref (.statics info) o)
-           =>
-           (lambda (global) (list (i386:label-mem-add `(#:address ,o) n))))
-          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
-           =>
-           (lambda (global) (list (i386:label-mem-add `(#:address ,global) n)))))))
-
-(define (ident-address-add info)
-  (lambda (o n)
-    (cond ((assoc-ref (.locals info) o)
-           =>
-           (lambda (local) (wrap-as (append (i386:push-accu)
-                                            (i386:local->accu (local:id local))
-                                            (i386:accu-mem-add n)
-                                            (i386:pop-accu)))))
-          ((assoc-ref (.statics info) o)
-           =>
-           (lambda (global) (list (wrap-as (append (i386:push-accu)
-                                                   (i386:label->accu `(#:address ,global))
-                                                   (i386:accu-mem-add n)
-                                                   (i386:pop-accu))))))
-          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
-           =>
-           (lambda (global) (list (wrap-as (append (i386:push-accu)
-                                                   (i386:label->accu `(#:address ,global))
-                                                   (i386:accu-mem-add n)
-                                                   (i386:pop-accu)))))))))
-
-(define (make-comment o)
-  (wrap-as `((#:comment ,o))))
-
-(define (ast->comment o)
-  (if mes? '()
-      (let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
-        (make-comment (string-join (string-split source #\newline) " ")))))
-
-(define (accu*n info n)
-  (append-text info (wrap-as (case n
-                               ((1) (i386:accu->base))
-                               ((2) (i386:accu+accu))
-                               ((3) (append (i386:accu->base)
-                                            (i386:accu+accu)
-                                            (i386:accu+base)))
-                               ((4) (i386:accu-shl 2))
-                               ((8) (append (i386:accu+accu)
-                                            (i386:accu-shl 2)))
-                               ((12) (append (i386:accu->base)
-                                             (i386:accu+accu)
-                                             (i386:accu+base)
-                                             (i386:accu-shl 2)))
-                               ((16) (i386:accu-shl 4))
-                               (else (append (i386:value->base n)
-                                             (i386:accu*base)))))))
-
-(define (accu->base-mem*n- info n)
-  (wrap-as
-   (case n
-     ((1) (i386:byte-accu->base-mem))
-     ((2) (i386:word-accu->base-mem))
-     ((4) (i386:accu->base-mem))
-     (else (append (let loop ((i 0))
-                     (if (>= i n) '()
-                         (append (if (= i 0) '()
-                                     (append (i386:accu+value 4)
-                                             (i386:base+value 4)))
-                                 (case (- n i)
-                                   ((1) (append (i386:accu+value -3)
-                                                (i386:base+value -3)
-                                                (i386:accu-mem->base-mem)))
-                                   ((2) (append (i386:accu+value -2)
-                                                (i386:base+value -2)
-                                                (i386:accu-mem->base-mem)))
-                                   ((3) (append (i386:accu+value -1)
-                                                (i386:base+value -1)
-                                                (i386:accu-mem->base-mem)))
-                                   (else (i386:accu-mem->base-mem)))
-                                 (loop (+ i 4))))))))))
-
-(define (accu->base-mem*n info n)
-  (append-text info (accu->base-mem*n- info n)))
-
-(define (expr->accu* o info)
-  (pmatch o
-
-    ((p-expr (ident ,name))
-     (append-text info ((ident-address->accu info) name)))
-
-    ((de-ref ,expr)
-     (expr->accu expr info))
-
-    ((d-sel (ident ,field) ,struct)
-     (let* ((type (ast->basic-type struct info))
-            (offset (field-offset info type field))
-            (info (expr->accu* struct info)))
-       (append-text info (wrap-as (i386:accu+value offset)))))
-
-    ((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest))
-     (let* ((type (ast->basic-type `(fctn-call (p-expr (ident ,function)) ,@rest) info))
-            (offset (field-offset info type field))
-            (info (expr->accu `(fctn-call (p-expr (ident ,function)) ,@rest) info)))
-       (append-text info (wrap-as (i386:accu+value offset)))))
-
-    ((i-sel (ident ,field) ,struct)
-     (let* ((type (ast->basic-type struct info))
-            (offset (field-offset info type field))
-            (info (expr->accu* struct info)))
-       (append-text info (append (wrap-as (i386:mem->accu))
-                                 (wrap-as (i386:accu+value offset))))))
-
-    ((array-ref ,index ,array)
-     (let* ((info (expr->accu index info))
-            (size (ast->size o info))
-            (info (accu*n info size))
-            (info (expr->base array info)))
-       (append-text info (wrap-as (i386:accu+base)))))
-
-    ((cast ,type ,expr)
-     (expr->accu `(ref-to ,expr) info))
-
-    ((add ,a ,b)
-     (let* ((rank (expr->rank info a))
-            (rank-b (expr->rank info b))
-            (type (ast->basic-type a info))
-            (struct? (structured-type? type))
-            (size (cond ((= rank 1) (ast-type->size info a))
-                        ((> rank 1) 4)
-                        ((and struct? (= rank 2)) 4)
-                        (else 1))))
-       (if (or (= size 1)) ((binop->accu* info) a b (i386:accu+base))
-           (let* ((info (expr->accu b info))
-                  (info (append-text info (wrap-as (append (i386:value->base size)
-                                                           (i386:accu*base)
-                                                           (i386:accu->base)))))
-                  (info (expr->accu* a info)))
-             (append-text info (wrap-as (i386:accu+base)))))))
-
-    ((sub ,a ,b)
-     (let* ((rank (expr->rank info a))
-            (rank-b (expr->rank info b))
-            (type (ast->basic-type a info))
-            (struct? (structured-type? type))
-            (size (->size type))
-            (size  (cond ((= rank 1) size)
-                         ((> rank 1) 4)
-                         ((and struct? (= rank 2)) 4)
-                         (else 1))))
-       (if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
-           (let ((info ((binop->accu* info) a b (i386:accu-base))))
-             (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
-                 (append-text info (wrap-as (append (i386:value->base size)
-                                                    (i386:accu/base))))))
-           (let* ((info (expr->accu* b info))
-                  (info (append-text info (wrap-as (append (i386:value->base size)
-                                                           (i386:accu*base)
-                                                           (i386:accu->base)))))
-                  (info (expr->accu* a info)))
-             (append-text info (wrap-as (i386:accu-base)))))))
-
-    ((pre-dec ,expr)
-     (let* ((rank (expr->rank info expr))
-            (size (cond ((= rank 1) (ast-type->size info expr))
-                        ((> rank 1) 4)
-                        (else 1)))
-            (info ((expr-add info) expr (- size)))
-            (info (append (expr->accu* expr info))))
-       info))
-
-    ((pre-inc ,expr)
-     (let* ((rank (expr->rank info expr))
-            (size (cond ((= rank 1) (ast-type->size info expr))
-                        ((> rank 1) 4)
-                        (else 1)))
-            (info ((expr-add info) expr size))
-            (info (append (expr->accu* expr info))))
-       info))
-
-    ((post-dec ,expr)
-     (let* ((info (expr->accu* expr info))
-            (info (append-text info (wrap-as (i386:push-accu))))
-            (post (clone info #:text '()))
-            (post (append-text post (ast->comment o)))
-            (post (append-text post (wrap-as (i386:pop-base))))
-            (post (append-text post (wrap-as (i386:push-accu))))
-            (post (append-text post (wrap-as (i386:base->accu))))
-            (rank (expr->rank post expr))
-            (size (cond ((= rank 1) (ast-type->size post expr))
-                        ((> rank 1) 4)
-                        (else 1)))
-            (post ((expr-add post) expr (- size)))
-            (post (append-text post (wrap-as (i386:pop-accu)))))
-       (clone info #:post (.text post))))
-
-    ((post-inc ,expr)
-     (let* ((info (expr->accu* expr info))
-            (info (append-text info (wrap-as (i386:push-accu))))
-            (post (clone info #:text '()))
-            (post (append-text post (ast->comment o)))
-            (post (append-text post (wrap-as (i386:pop-base))))
-            (post (append-text post (wrap-as (i386:push-accu))))
-            (post (append-text post (wrap-as (i386:base->accu))))
-            (rank (expr->rank post expr))
-            (size (cond ((= rank 1) (ast-type->size post expr))
-                        ((> rank 1) 4)
-                        (else 1)))
-            (post ((expr-add post) expr size))
-            (post (append-text post (wrap-as (i386:pop-accu)))))
-       (clone info #:post (.text post))))
-
-    (_ (error "expr->accu*: not supported: " o))))
-
-(define (expr-add info)
-  (lambda (o n)
-    (let* ((info (expr->accu* o info))
-           (info (append-text info (wrap-as (i386:accu-mem-add n)))))
-      info)))
-
-(define (expr->accu o info)
-  (let ((locals (.locals info))
-        (text (.text info))
-        (globals (.globals info)))
-    (define (helper)
-      (pmatch o
-        ((expr) info)
-
-        ((comma-expr) info)
-
-        ((comma-expr ,a . ,rest)
-         (let ((info (expr->accu a info)))
-           (expr->accu `(comma-expr ,@rest) info)))
-
-        ((p-expr (string ,string))
-         (let* ((globals ((globals:add-string globals) string))
-                (info (clone info #:globals globals)))
-           (append-text info (list (i386:label->accu `(#:string ,string))))))
-
-        ((p-expr (string . ,strings))
-         (let* ((string (apply string-append strings))
-                (globals ((globals:add-string globals) string))
-                (info (clone info #:globals globals)))
-           (append-text info (list (i386:label->accu `(#:string ,string))))))
-
-        ((p-expr (fixed ,value))
-         (let ((value (cstring->int value)))
-           (append-text info (wrap-as (i386:value->accu value)))))
-
-        ((p-expr (float ,value))
-         (let ((value (cstring->float value)))
-           (append-text info (wrap-as (i386:value->accu value)))))
-
-        ((neg (p-expr (fixed ,value)))
-         (let ((value (- (cstring->int value))))
-           (append-text info (wrap-as (i386:value->accu value)))))
-
-        ((p-expr (char ,char))
-         (let ((char (char->integer (car (string->list char)))))
-           (append-text info (wrap-as (i386:value->accu char)))))
-
-        (,char (guard (char? char)) (append-text info (wrap-as (i386:value->accu char))))
-
-        ((p-expr (ident ,name))
-         (append-text info ((ident->accu info) name)))
-
-        ((initzer ,initzer)
-         (expr->accu initzer info))
-
-        (((initzer ,initzer))
-         (expr->accu initzer info))
-
-        ;; offsetoff
-        ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
-         (let* ((type (ast->basic-type struct info))
-                (offset (field-offset info type field))
-                (base (cstring->int base)))
-           (append-text info (wrap-as (i386:value->accu (+ base offset))))))
-
-        ;; &foo
-        ((ref-to (p-expr (ident ,name)))
-         (append-text info ((ident-address->accu info) name)))
-
-        ;; &*foo
-        ((ref-to (de-ref ,expr))
-         (expr->accu expr info))
-
-        ((ref-to ,expr)
-         (expr->accu* expr info))
-
-        ((sizeof-expr ,expr)
-         (append-text info (wrap-as (i386:value->accu (ast->size expr info)))))
-
-        ((sizeof-type ,type)
-         (append-text info (wrap-as (i386:value->accu (ast->size type info)))))
-
-        ((array-ref ,index ,array)
-         (let* ((info (expr->accu* o info))
-                (type (ast->type o info)))
-           (append-text info (mem->accu type))))
-
-        ((d-sel ,field ,struct)
-         (let* ((info (expr->accu* o info))
-                (info (append-text info (ast->comment o)))
-                (type (ast->type o info))
-                (size (->size type))
-                (array? (c-array? type)))
-           (if array? info
-               (append-text info (mem->accu type)))))
-
-        ((i-sel ,field ,struct)
-         (let* ((info (expr->accu* o info))
-                (info (append-text info (ast->comment o)))
-                (type (ast->type o info))
-                (size (->size type))
-                (array? (c-array? type)))
-           (if array? info
-               (append-text info (mem->accu type)))))
-
-        ((de-ref ,expr)
-         (let* ((info (expr->accu expr info))
-                (type (ast->type o info)))
-           (append-text info (mem->accu type))))
-
-        ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
-         (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
-                                   (append-text info (wrap-as (asm->m1 arg0))))
-             (let* ((text-length (length text))
-                    (args-info (let loop ((expressions (reverse expr-list)) (info info))
-                                 (if (null? expressions) info
-                                     (loop (cdr expressions) ((expr->arg info) (car expressions))))))
-                    (n (length expr-list)))
-               (if (not (assoc-ref locals name))
-                   (begin
-                     (if (and (not (assoc name (.functions info)))
-                              (not (assoc name globals))
-                              (not (equal? name (.function info))))
-                         (stderr "warning: undeclared function: ~a\n" name))
-                     (append-text args-info (list (i386:call-label name n))))
-                   (let* ((empty (clone info #:text '()))
-                          (accu (expr->accu `(p-expr (ident ,name)) empty)))
-                     (append-text args-info (append (.text accu)
-                                                    (list (i386:call-accu n)))))))))
-
-        ((fctn-call ,function (expr-list . ,expr-list))
-         (let* ((text-length (length text))
-                (args-info (let loop ((expressions (reverse expr-list)) (info info))
-                             (if (null? expressions) info
-                                 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
-                (n (length expr-list))
-                (empty (clone info #:text '()))
-                (accu (expr->accu function empty)))
-           (append-text args-info (append (.text accu)
-                                          (list (i386:call-accu n))))))
-
-        ((cond-expr . ,cond-expr)
-         (ast->info `(expr-stmt ,o) info))
-
-        ((post-inc ,expr)
-         (let* ((info (append (expr->accu expr info)))
-                (info (append-text info (wrap-as (i386:push-accu))))
-                (rank (expr->rank info expr))
-                (size (cond ((= rank 1) (ast-type->size info expr))
-                            ((> rank 1) 4)
-                            (else 1)))
-                (info ((expr-add info) expr size))
-                (info (append-text info (wrap-as (i386:pop-accu)))))
-           info))
-
-        ((post-dec ,expr)
-         (let* ((info (append (expr->accu expr info)))
-                (info (append-text info (wrap-as (i386:push-accu))))
-                (rank (expr->rank info expr))
-                (size (cond ((= rank 1) (ast-type->size info expr))
-                            ((> rank 1) 4)
-                            (else 1)))
-                (info ((expr-add info) expr (- size)))
-                (info (append-text info (wrap-as (i386:pop-accu)))))
-           info))
-
-        ((pre-inc ,expr)
-         (let* ((rank (expr->rank info expr))
-                (size (cond ((= rank 1) (ast-type->size info expr))
-                            ((> rank 1) 4)
-                            (else 1)))
-                (info ((expr-add info) expr size))
-                (info (append (expr->accu expr info))))
-           info))
-
-        ((pre-dec ,expr)
-         (let* ((rank (expr->rank info expr))
-                (size (cond ((= rank 1) (ast-type->size info expr))
-                            ((> rank 1) 4)
-                            (else 1)))
-                (info ((expr-add info) expr (- size)))
-                (info (append (expr->accu expr info))))
-           info))
-
-
-
-        ((add ,a (p-expr (fixed ,value)))
-         (let* ((rank (expr->rank info a))
-                (type (ast->basic-type a info))
-                (struct? (structured-type? type))
-                (size (cond ((= rank 1) (ast-type->size info a))
-                            ((> rank 1) 4)
-                            ((and struct? (= rank 2)) 4)
-                            (else 1)))
-                (info (expr->accu a info))
-                (value (cstring->int value))
-                (value (* size value)))
-           (append-text info (wrap-as (i386:accu+value value)))))
-
-        ((add ,a ,b)
-         (let* ((rank (expr->rank info a))
-                (rank-b (expr->rank info b))
-                (type (ast->basic-type a info))
-                (struct? (structured-type? type))
-                (size (cond ((= rank 1) (ast-type->size info a))
-                            ((> rank 1) 4)
-                            ((and struct? (= rank 2)) 4)
-                            (else 1))))
-           (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base))
-               (let* ((info (expr->accu b info))
-                      (info (append-text info (wrap-as (append (i386:value->base size)
-                                                               (i386:accu*base)
-                                                               (i386:accu->base)))))
-                      (info (expr->accu a info)))
-                 (append-text info (wrap-as (i386:accu+base)))))))
-
-        ((sub ,a (p-expr (fixed ,value)))
-         (let* ((rank (expr->rank info a))
-                (type (ast->basic-type a info))
-                (struct? (structured-type? type))
-                (size (->size type))
-                (size (cond ((= rank 1) size)
-                            ((> rank 1) 4)
-                            ((and struct? (= rank 2)) 4)
-                            (else 1)))
-                (info (expr->accu a info))
-                (value (cstring->int value))
-                (value (* size value)))
-           (append-text info (wrap-as (i386:accu+value (- value))))))
-
-        ((sub ,a ,b)
-         (let* ((rank (expr->rank info a))
-                (rank-b (expr->rank info b))
-                (type (ast->basic-type a info))
-                (struct? (structured-type? type))
-                (size (->size type))
-                (size  (cond ((= rank 1) size)
-                             ((> rank 1) 4)
-                             ((and struct? (= rank 2)) 4)
-                             (else 1))))
-           (if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
-               (let ((info ((binop->accu info) a b (i386:accu-base))))
-                 (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
-                     (append-text info (wrap-as (append (i386:value->base size)
-                                                        (i386:accu/base))))))
-               (let* ((info (expr->accu b info))
-                      (info (append-text info (wrap-as (append (i386:value->base size)
-                                                               (i386:accu*base)
-                                                               (i386:accu->base)))))
-                      (info (expr->accu a info)))
-                 (append-text info (wrap-as (i386:accu-base)))))))
-
-        ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
-        ((bitwise-not ,expr)
-         (let ((info (ast->info expr info)))
-           (append-text info (wrap-as (i386:accu-not)))))
-        ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
-        ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base)))
-        ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
-        ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
-        ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
-        ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
-        ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
-
-        ((not ,expr)
-         (let* ((test-info (ast->info expr info)))
-           (clone info #:text
-                  (append (.text test-info)
-                          (wrap-as (i386:accu-negate)))
-                  #:globals (.globals test-info))))
-
-        ((neg ,expr)
-         (let ((info (expr->base expr info)))
-           (append-text info (append (wrap-as (i386:value->accu 0))
-                                     (wrap-as (i386:sub-base))))))
-
-        ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu))))
-
-        ((ge ,a ,b)
-         (let* ((type-a (ast->type a info))
-                (type-b (ast->type b info))
-                (test->accu (if (or (unsigned? type-a) (unsigned? type-b)) i386:ae?->accu i386:ge?->accu)))
-           ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
-
-        ((gt ,a ,b)
-         (let* ((type-a (ast->type a info))
-                (type-b (ast->type b info))
-                (test->accu (if (or (unsigned? type-a) (unsigned? type-b)) i386:a?->accu i386:g?->accu)))
-           ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
-
-        ;; FIXME: set accu *and* flags
-        ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu)
-                                                    (i386:sub-base)
-                                                    (i386:nz->accu)
-                                                    (i386:accu<->stack)
-                                                    (i386:sub-base)
-                                                    (i386:xor-zf)
-                                                    (i386:pop-accu))))
-
-        ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf))))
-
-        ((le ,a ,b)
-         (let* ((type-a (ast->type a info))
-                (type-b (ast->type b info))
-                (test->accu (if (or (unsigned? type-a) (unsigned? type-b)) i386:be?->accu i386:le?->accu)))
-           ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
-
-        ((lt ,a ,b)
-         (let* ((type-a (ast->type a info))
-                (type-b (ast->type b info))
-                (test->accu (if (or (unsigned? type-a) (unsigned? type-b)) i386:b?->accu i386:l?->accu)))
-           ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
-
-        ((or ,a ,b)
-         (let* ((info (expr->accu a info))
-                (here (number->string (length (.text info))))
-                (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b"))
-                (info (append-text info (wrap-as (i386:accu-test))))
-                (info (append-text info (wrap-as (i386:jump-nz skip-b-label))))
-                (info (append-text info (wrap-as (i386:accu-test))))
-                (info (expr->accu b info))
-                (info (append-text info (wrap-as (i386:accu-test))))
-                (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
-           info))
-
-        ((and ,a ,b)
-         (let* ((info (expr->accu a info))
-                (here (number->string (length (.text info))))
-                (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b"))
-                (info (append-text info (wrap-as (i386:accu-test))))
-                (info (append-text info (wrap-as (i386:jump-z skip-b-label))))
-                (info (append-text info (wrap-as (i386:accu-test))))
-                (info (expr->accu b info))
-                (info (append-text info (wrap-as (i386:accu-test))))
-                (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
-           info))
-
-        ((cast ,type ,expr)
-         (let ((info (expr->accu expr info))
-               (type (ast->type o info)))
-           (append-text info (convert-accu type))))
-
-        ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
-         (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
-                (type (ident->type info name))
-                (rank (ident->rank info name))
-                (size (if (> rank 1) 4 1)))
-           (append-text info ((ident-add info) name size))))
-
-        ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
-         (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
-                (type (ident->type info name))
-                (rank (ident->rank info name))
-                (size (if (> rank 1) 4 1)))
-           (append-text info ((ident-add info) name (- size)))))
-
-        ((assn-expr ,a (op ,op) ,b)
-         (let* ((info (append-text info (ast->comment o)))
-                (type (ast->type a info))
-                (rank (->rank type))
-                (type-b (ast->type b info))
-                (rank-b (->rank type-b))
-                (size (if (zero? rank) (->size type) 4))
-                (size-b (if (zero? rank-b) (->size type-b) 4))
-                (info (expr->accu b info))
-                (info (if (equal? op "=") info
-                          (let* ((struct? (structured-type? type))
-                                 (size (cond ((= rank 1) (ast-type->size info a))
-                                             ((> rank 1) 4)
-                                             ((and struct? (= rank 2)) 4)
-                                             (else 1)))
-                                 (info (if (or (= size 1) (= rank-b 1)) info
-                                           (let ((info (append-text info (wrap-as (i386:value->base size)))))
-                                             (append-text info (wrap-as (i386:accu*base))))))
-                                 (info (append-text info (wrap-as (i386:push-accu))))
-                                 (info (expr->accu a info))
-                                 (info (append-text info (wrap-as (i386:pop-base))))
-                                 (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
-                                                               ((equal? op "-=") (wrap-as (i386:accu-base)))
-                                                               ((equal? op "*=") (wrap-as (i386:accu*base)))
-                                                               ((equal? op "/=") (wrap-as (i386:accu/base)))
-                                                               ((equal? op "%=") (wrap-as (i386:accu%base)))
-                                                               ((equal? op "&=") (wrap-as (i386:accu-and-base)))
-                                                               ((equal? op "|=") (wrap-as (i386:accu-or-base)))
-                                                               ((equal? op "^=") (wrap-as (i386:accu-xor-base)))
-                                                               ((equal? op ">>=") (wrap-as (i386:accu>>base)))
-                                                               ((equal? op "<<=") (wrap-as (i386:accu<<base)))
-                                                               (else (error (format #f "mescc: op ~a not supported: ~a\n" op o)))))))
-                            (cond ((not (and (= rank 1) (= rank-b 1))) info)
-                                  ((equal? op "-=") (append-text info (wrap-as (append (i386:value->base size)
-                                                                                       (i386:accu/base)))))
-                                  (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type (ast->basic-type b info)))))))))
-           (when (and (equal? op "=")
-                      (not (= size size-b))
-                      (not (and (or (= size 1) (= size 2))
-                                (or (= size-b 2) (= size-b 4))))
-                      (not (and (= size 2)
-                                (= size-b 4)))
-                      (not (and (= size 4)
-                                (or (= size-b 1) (= size-b 2)))))
-             (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o))))
-             (stderr "   size[~a]:~a != size[~a]:~a\n"  rank size rank-b size-b))
-           (pmatch a
-             ((p-expr (ident ,name))
-              (if (or (<= size 4) ;; FIXME: long long = int
-                      (<= size-b 4)) (append-text info ((accu->ident info) name))
-                      (let ((info (expr->base* a info)))
-                        (accu->base-mem*n info size))))
-             (_ (let* ((info (expr->base* a info))
-                       (info (if (not (bit-field? type)) info
-                                 (let* ((bit (bit-field:bit type))
-                                        (bits (bit-field:bits type))
-                                        (set-mask (- (ash bits 1) 1))
-                                        (shifted-set-mask (ash set-mask bit))
-                                        (clear-mask (logxor shifted-set-mask #b11111111111111111111111111111111))
-                                        (info (append-text info (wrap-as (i386:push-base))))
-                                        (info (append-text info (wrap-as (i386:push-accu))))
-
-                                        (info (append-text info (wrap-as (i386:base-mem->accu))))
-                                        (info (append-text info (wrap-as (i386:accu-and clear-mask))))
-                                        (info (append-text info (wrap-as (i386:accu->base))))
-
-                                        (info (append-text info (wrap-as (i386:pop-accu))))
-                                        (info (append-text info (wrap-as (i386:accu-and set-mask))))
-                                        (info (append-text info (wrap-as (i386:accu-shl bit))))
-                                        (info (append-text info (wrap-as (i386:accu-or-base))))
-
-                                        (info (append-text info (wrap-as (i386:pop-base)))))
-                                   info))))
-                  (accu->base-mem*n info (min size (max 4 size-b)))))))) ;; FIXME: long long = int
-
-        (_ (error "expr->accu: not supported: " o))))
-
-    (let ((info (helper)))
-      (if (null? (.post info)) info
-          (append-text (clone info #:post '()) (.post info))))))
-
-(define (mem->accu type)
-  (let ((size (->size type)))
-    (case size
-      ((1) (append (wrap-as (i386:byte-mem->accu)) (convert-accu type)))
-      ((2) (append (wrap-as (i386:word-mem->accu)) (convert-accu type)))
-      ((4) (wrap-as (i386:mem->accu)))
-      (else '()))))
-
-(define (convert-accu type)
-  (if (not (type? type)) '()
-      (let ((sign (signed? type))
-            (size (->size type)))
-        (cond ((and (= size 1) sign)
-               (wrap-as (i386:signed-byte-accu)))
-              ((= size 1)
-               (wrap-as (i386:byte-accu)))
-              ((and (= size 2) sign)
-               (wrap-as (i386:signed-word-accu)))
-              ((= size 1)
-               (wrap-as (i386:word-accu)))
-              (else '())))))
-
-(define (expr->base o info)
-  (let* ((info (append-text info (wrap-as (i386:push-accu))))
-         (info (expr->accu o info))
-         (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
-    info))
-
-(define (binop->accu info)
-  (lambda (a b c)
-    (let* ((info (expr->accu a info))
-           (info (expr->base b info)))
-      (append-text info (wrap-as c)))))
-
-(define (binop->accu* info)
-  (lambda (a b c)
-    (let* ((info (expr->accu* a info))
-           (info (expr->base b info)))
-      (append-text info (wrap-as c)))))
-
-(define (wrap-as o . annotation)
-  `(,@annotation ,o))
-
-(define (expr->base* o info)
-  (let* ((info (append-text info (wrap-as (i386:push-accu))))
-         (info (expr->accu* o info))
-         (info (append-text info (wrap-as (i386:accu->base))))
-         (info (append-text info (wrap-as (i386:pop-accu)))))
-    info))
-
-(define (comment? o)
-  (and (pair? o) (pair? (car o)) (eq? (caar o) #:comment)))
-
-(define (test-jump-label->info info label)
-  (define (jump type . test)
-    (lambda (o)
-      (let* ((info (ast->info o info))
-             (info (append-text info (make-comment "jmp test LABEL")))
-             (jump-text (wrap-as (type label))))
-        (append-text info (append (if (null? test) '() (car test))
-                                  jump-text)))))
-  (lambda (o)
-    (pmatch o
-      ((expr) info)
-      ((le ,a ,b) ((jump i386:jump-z) o))
-      ((lt ,a ,b) ((jump i386:jump-z) o))
-      ((ge ,a ,b) ((jump i386:jump-z) o))
-      ((gt ,a ,b) ((jump i386:jump-z) o))
-      ((ne ,a ,b) ((jump i386:jump-nz) o))
-      ((eq ,a ,b) ((jump i386:jump-nz) o))
-      ((not _) ((jump i386:jump-z) o))
-
-      ((and ,a ,b)
-       (let* ((info ((test-jump-label->info info label) a))
-              (info ((test-jump-label->info info label) b)))
-         info))
-
-      ((or ,a ,b)
-       (let* ((here (number->string (length (if mes? (.text info)
-                                                (filter (negate comment?) (.text info))))))
-              (skip-b-label (string-append label "_skip_b_" here))
-              (b-label (string-append label "_b_" here))
-              (info ((test-jump-label->info info b-label) a))
-              (info (append-text info (wrap-as (i386:jump skip-b-label))))
-              (info (append-text info (wrap-as `((#:label ,b-label)))))
-              (info ((test-jump-label->info info label) b))
-              (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
-         info))
-
-      ((array-ref ,index ,expr) (let* ((rank (expr->rank info expr))
-                                       (size (if (= rank 1) (ast-type->size info expr)
-                                                 4)))
-                                  ((jump (if (= size 1) i386:jump-byte-z
-                                             i386:jump-z)
-                                         (wrap-as (i386:accu-zero?))) o)))
-
-      ((de-ref ,expr) (let* ((rank (expr->rank info expr))
-                             (size (if (= rank 1) (ast-type->size info expr)
-                                       4)))
-                        ((jump (if (= size 1) i386:jump-byte-z
-                                   i386:jump-z)
-                               (wrap-as (i386:accu-zero?))) o)))
-
-      ((assn-expr (p-expr (ident ,name)) ,op ,expr)
-       ((jump i386:jump-z
-              (append ((ident->accu info) name)
-                      (wrap-as (i386:accu-zero?)))) o))
-
-      (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
-
-(define (cstring->int o)
-  (let ((o (cond ((string-suffix? "ULL" o) (string-drop-right o 3))
-                 ((string-suffix? "UL" o) (string-drop-right o 2))
-                 ((string-suffix? "LL" o) (string-drop-right o 2))
-                 ((string-suffix? "L" o) (string-drop-right o 1))
-                 (else o))))
-    (or (cond ((string-prefix? "0x" o) (string->number (string-drop o 2) 16))
-              ((string-prefix? "0b" o) (string->number (string-drop o 2) 2))
-              ((string-prefix? "0" o) (string->number o 8))
-              (else (string->number o)))
-        (error "cstring->int: not supported:" o))))
-
-(define (cstring->float o)
-  (or (string->number o)
-      (error "cstring->float: not supported:" o)))
-
-(define (try-expr->number info o)
-  (pmatch o
-    ((fixed ,a) (cstring->int a))
-    ((p-expr ,expr) (expr->number info expr))
-    ((neg ,a)
-     (- (expr->number info a)))
-    ((add ,a ,b)
-     (+ (expr->number info a) (expr->number info b)))
-    ((bitwise-and ,a ,b)
-     (logand (expr->number info a) (expr->number info b)))
-    ((bitwise-not ,a)
-     (lognot (expr->number info a)))
-    ((bitwise-or ,a ,b)
-     (logior (expr->number info a) (expr->number info b)))
-    ((div ,a ,b)
-     (quotient (expr->number info a) (expr->number info b)))
-    ((mul ,a ,b)
-     (* (expr->number info a) (expr->number info b)))
-    ((sub ,a ,b)
-     (- (expr->number info a) (expr->number info b)))
-    ((sizeof-type ,type)
-     (->size (ast->type type info)))
-    ((sizeof-expr ,expr)
-     (->size (ast->type expr info)))
-    ((lshift ,x ,y)
-     (ash (expr->number info x) (expr->number info y)))
-    ((rshift ,x ,y)
-     (ash (expr->number info x) (- (expr->number info y))))
-    ((p-expr (ident ,name))
-     (let ((value (assoc-ref (.constants info) name)))
-       (or value
-           (error (format #f "expr->number: undeclared identifier: ~s\n" o)))))
-    ((cast ,type ,expr) (expr->number info expr))
-    ((cond-expr ,test ,then ,else)
-     (if (p-expr->bool info test) (expr->number info then) (expr->number info else)))
-    (,string (guard (string? string)) (cstring->int string))
-    ((ident ,name) (assoc-ref (.constants info) name))
-    (_  #f)))
-
-(define (expr->number info o)
-  (or (try-expr->number info  o)
-      (error (format #f "expr->number: not supported: ~s\n" o))))
-
-(define (p-expr->bool info o)
-  (pmatch o
-    ((eq ,a ,b) (eq? (expr->number info a) (expr->number info b)))))
-
-(define (struct-field info)
-  (lambda (o)
-    (pmatch o
-      ((comp-decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))) (comp-declr-list . ,decls))
-       (let (
-             ;;(constants (enum-def-list->constants (.constants info) fields))
-             ;;(type-entry (enum->type-entry name fields))
-             )
-         (append-map (lambda (o)
-                       ((struct-field info) `(comp-decl (decl-spec-list (type-spec "int")) (comp-declr-list ,o))))
-                     decls)))
-    ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ident ,name))))
-       (list (cons name (ast->type type info))))
-      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (ident ,name)))))
-       (let ((rank (pointer->rank pointer)))
-         (list (cons name (rank+= (ast->type type info) rank)))))
-      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr ,pointer (ident ,name))) _))))
-       (let ((rank (pointer->rank pointer)))
-         (list (cons name (rank+= (ast->type type info) rank)))))
-      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (array-of (ident ,name) ,count)))))
-       (let ((rank (pointer->rank pointer))
-             (count (expr->number info count)))
-         (list (cons name (make-c-array (rank+= type rank) count)))))
-      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
-       (let ((count (expr->number info count)))
-         (list (cons name (make-c-array (ast->type type info) count)))))
-      ((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
-       (let ((fields (append-map (struct-field info) fields)))
-         (list (cons 'struct (make-type 'struct (apply + (map field:size fields)) fields)))))
-      ((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
-       (let ((fields (append-map (struct-field info) fields)))
-         (list (cons 'union (make-type 'union (apply + (map field:size fields)) fields)))))
-      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields))
-       (let ((type (ast->type type info)))
-         (list (cons 'bits (let loop ((o `((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields)) (bit 0))
-                             (if (null? o) '()
-                                 (let ((field (car o)))
-                                   (pmatch field
-                                     ((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits))))
-                                      (let ((bits (cstring->int bits)))
-                                        (cons (cons name (make-bit-field type bit bits))
-                                              (loop (cdr o) (+ bit bits)))))
-                                     (_ (error "struct-field: not supported:" field o))))))))))
-      ((comp-decl (decl-spec-list ,type) (comp-declr-list . ,decls))
-       (append-map (lambda (o)
-                     ((struct-field info) `(comp-decl (decl-spec-list ,type) (comp-declr-list ,o))))
-                   decls))
-      (_ (error "struct-field: not supported: " o)))))
-
-(define (local-var? o) ;; formals < 0, locals > 0
-  (positive? (local:id o)))
-
-(define (ptr-declr->rank o)
-  (pmatch o
-    ((pointer) 1)
-    ((pointer (pointer)) 2)
-    ((pointer (pointer (pointer))) 3)
-    (_ (error "ptr-declr->rank not supported: " o))))
-
-(define (ast->info o info)
-  (let ((functions (.functions info))
-        (globals (.globals info))
-        (locals (.locals info))
-        (constants (.constants info))
-        (types (.types info))
-        (text (.text info)))
-    (pmatch o
-      (((trans-unit . _) . _) (ast-list->info o info))
-      ((trans-unit . ,_) (ast-list->info _ info))
-      ((fctn-defn . ,_) (fctn-defn->info _ info))
-
-      ((cpp-stmt (define (name ,name) (repl ,value)))
-       info)
-
-      ((cast (type-name (decl-spec-list (type-spec (void)))) _)
-       info)
-
-      ((break)
-       (let ((label (car (.break info))))
-         (append-text info (wrap-as (i386:jump label)))))
-
-      ((continue)
-       (let ((label (car (.continue info))))
-         (append-text info (wrap-as (i386:jump label)))))
-
-      ;; FIXME: expr-stmt wrapper?
-      (trans-unit info)
-      ((expr-stmt) info)
-
-      ((compd-stmt (block-item-list . ,_)) (ast-list->info _ info))
-
-      ((asm-expr ,gnuc (,null ,arg0 . string))
-       (append-text info (wrap-as (asm->m1 arg0))))
-
-      ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
-       (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
-                                 (append-text info (wrap-as (asm->m1 arg0))))
-           (let* ((info (append-text info (ast->comment o)))
-                  (info (expr->accu `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) info)))
-             (append-text info (wrap-as (i386:accu-zero?))))))
-
-      ((if ,test ,then)
-       (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
-              (here (number->string (length text)))
-              (label (string-append "_" (.function info) "_" here "_"))
-              (break-label (string-append label "break"))
-              (else-label (string-append label "else"))
-              (info ((test-jump-label->info info break-label) test))
-              (info (ast->info then info))
-              (info (append-text info (wrap-as (i386:jump break-label))))
-              (info (append-text info (wrap-as `((#:label ,break-label))))))
-         (clone info
-                #:locals locals)))
-
-      ((if ,test ,then ,else)
-       (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
-              (here (number->string (length text)))
-              (label (string-append "_" (.function info) "_" here "_"))
-              (break-label (string-append label "break"))
-              (else-label (string-append label "else"))
-              (info ((test-jump-label->info info else-label) test))
-              (info (ast->info then info))
-              (info (append-text info (wrap-as (i386:jump break-label))))
-              (info (append-text info (wrap-as `((#:label ,else-label)))))
-              (info (ast->info else info))
-              (info (append-text info (wrap-as `((#:label ,break-label))))))
-         (clone info
-                #:locals locals)))
-
-      ;; Hmm?
-      ((expr-stmt (cond-expr ,test ,then ,else))
-       (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
-              (here (number->string (length text)))
-              (label (string-append "_" (.function info) "_" here "_"))
-              (else-label (string-append label "else"))
-              (break-label (string-append label "break"))
-              (info ((test-jump-label->info info else-label) test))
-              (info (ast->info then info))
-              (info (append-text info (wrap-as (i386:jump break-label))))
-              (info (append-text info (wrap-as `((#:label ,else-label)))))
-              (info (ast->info else info))
-              (info (append-text info (wrap-as `((#:label ,break-label))))))
-         info))
-
-      ((switch ,expr (compd-stmt (block-item-list . ,statements)))
-       (define (clause? o)
-         (pmatch o
-           ((case . _) 'case)
-           ((default . _) 'default)
-           ((labeled-stmt _ ,statement) (clause? statement))
-           (_ #f)))
-       (define clause-number
-         (let ((i 0))
-           (lambda (o)
-             (let ((n i))
-               (when (clause? (car o))
-                 (set! i (1+ i)))
-               n))))
-       (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
-              (here (number->string (length text)))
-              (label (string-append "_" (.function info) "_" here "_"))
-              (break-label (string-append label "break"))
-              (info (expr->accu expr info))
-              (info (clone info #:break (cons break-label (.break info))))
-              (count (length (filter clause? statements)))
-              (default? (find (cut eq? <> 'default) (map clause? statements)))
-              (info (fold (cut switch->info #t label (1- count) <> <> <>) info statements
-                          (unfold null? clause-number cdr statements)))
-              (last-clause-label (string-append label "clause" (number->string count)))
-              (default-label (string-append label "default"))
-              (info (if (not default?) info
-                        (append-text info (wrap-as (i386:jump break-label)))))
-              (info (append-text info (wrap-as `((#:label ,last-clause-label)))))
-              (info (if (not default?) info
-                        (append-text info (wrap-as (i386:jump default-label)))))
-              (info (append-text info (wrap-as `((#:label ,break-label))))))
-         (clone info
-                #:locals locals
-                #:break (cdr (.break info)))))
-
-      ((for ,init ,test ,step ,body)
-       (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
-              (here (number->string (length text)))
-              (label (string-append "_" (.function info) "_" here "_"))
-              (break-label (string-append label "break"))
-              (loop-label (string-append label "loop"))
-              (continue-label (string-append label "continue"))
-              (initial-skip-label (string-append label "initial_skip"))
-              (info (ast->info init info))
-              (info (clone info #:break (cons break-label (.break info))))
-              (info (clone info #:continue (cons continue-label (.continue info))))
-              (info (append-text info (wrap-as (i386:jump initial-skip-label))))
-              (info (append-text info (wrap-as `((#:label ,loop-label)))))
-              (info (ast->info body info))
-              (info (append-text info (wrap-as `((#:label ,continue-label)))))
-              (info (expr->accu step info))
-              (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
-              (info ((test-jump-label->info info break-label) test))
-              (info (append-text info (wrap-as (i386:jump loop-label))))
-              (info (append-text info (wrap-as `((#:label ,break-label))))))
-         (clone info
-                #:locals locals
-                #:break (cdr (.break info))
-                #:continue (cdr (.continue info)))))
-
-      ((while ,test ,body)
-       (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
-              (here (number->string (length text)))
-              (label (string-append "_" (.function info) "_" here "_"))
-              (break-label (string-append label "break"))
-              (loop-label (string-append label "loop"))
-              (continue-label (string-append label "continue"))
-              (info (append-text info (wrap-as (i386:jump continue-label))))
-              (info (clone info #:break (cons break-label (.break info))))
-              (info (clone info #:continue (cons continue-label (.continue info))))
-              (info (append-text info (wrap-as `((#:label ,loop-label)))))
-              (info (ast->info body info))
-              (info (append-text info (wrap-as `((#:label ,continue-label)))))
-              (info ((test-jump-label->info info break-label) test))
-              (info (append-text info (wrap-as (i386:jump loop-label))))
-              (info (append-text info (wrap-as `((#:label ,break-label))))))
-         (clone info
-                #:locals locals
-                #:break (cdr (.break info))
-                #:continue (cdr (.continue info)))))
-
-      ((do-while ,body ,test)
-       (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
-              (here (number->string (length text)))
-              (label (string-append "_" (.function info) "_" here "_"))
-              (break-label (string-append label "break"))
-              (loop-label (string-append label "loop"))
-              (continue-label (string-append label "continue"))
-              (info (clone info #:break (cons break-label (.break info))))
-              (info (clone info #:continue (cons continue-label (.continue info))))
-              (info (append-text info (wrap-as `((#:label ,loop-label)))))
-              (info (ast->info body info))
-              (info (append-text info (wrap-as `((#:label ,continue-label)))))
-              (info ((test-jump-label->info info break-label) test))
-              (info (append-text info (wrap-as (i386:jump loop-label))))
-              (info (append-text info (wrap-as `((#:label ,break-label))))))
-         (clone info
-                #:locals locals
-                #:break (cdr (.break info))
-                #:continue (cdr (.continue info)))))
-
-      ((labeled-stmt (ident ,label) ,statement)
-       (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" label)))))))
-         (ast->info statement info)))
-
-      ((goto (ident ,label))
-       (append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label)))))
-
-      ((return ,expr)
-       (let ((info (expr->accu expr info)))
-         (append-text info (append (wrap-as (i386:ret))))))
-
-      ((decl . ,decl)
-       ;;FIXME: ridiculous performance hit with mes
-       ;; Nyacc 0.80.42: missing  (enum-ref (ident "fred"))
-       (let ( ;;(info (append-text info (ast->comment o)))
-             )
-         (decl->info info decl)))
-      ;; ...
-      ((gt . _) (expr->accu o info))
-      ((ge . _) (expr->accu o info))
-      ((ne . _) (expr->accu o info))
-      ((eq . _) (expr->accu o info))
-      ((le . _) (expr->accu o info))
-      ((lt . _) (expr->accu o info))
-      ((lshift . _) (expr->accu o info))
-      ((rshift . _) (expr->accu o info))
-
-      ;; EXPR
-      ((expr-stmt ,expression)
-       (let ((info (expr->accu expression info)))
-         (append-text info (wrap-as (i386:accu-zero?)))))
-
-      ;; FIXME: why do we get (post-inc ...) here
-      ;; (array-ref
-      (_ (let ((info (expr->accu o info)))
-           (append-text info (wrap-as (i386:accu-zero?))))))))
-
-(define (ast-list->info o info)
-  (fold ast->info info o))
-
-(define (switch->info clause? label count o i info)
-  (let* ((i-string (number->string i))
-         (i+1-string (number->string (1+ i)))
-         (body-label (string-append label "body" i-string))
-         (clause-label (string-append label "clause" i-string))
-         (last? (= i count))
-         (break-label (string-append label "break"))
-         (next-clause-label (string-append label "clause" i+1-string))
-         (default-label (string-append label "default")))
-    (define (jump label)
-      (wrap-as (i386:jump label)))
-    (pmatch o
-      ((case ,test)
-       (define (jump-nz label)
-         (wrap-as (i386:jump-nz label)))
-       (define (jump-z label)
-         (wrap-as (i386:jump-z label)))
-       (define (test->text test)
-         (let ((value (pmatch test
-                        (0 0)
-                        ((p-expr (char ,value)) (char->integer (car (string->list value))))
-                        ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
-                        ((p-expr (fixed ,value)) (cstring->int value))
-                        ((neg (p-expr (fixed ,value))) (- (cstring->int value)))
-                        (_ (error "case test: not supported: " test)))))
-           (append (wrap-as (i386:accu-cmp-value value))
-                   (jump-z body-label))))
-       (let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                       info)))
-         (append-text info (test->text test))))
-      ((case ,test (case . ,case1))
-       (let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                       info)))
-         (fold (cut switch->info #f label count <> i <>) info (cons `(case ,test) `((case ,@case1))))))
-      ((case ,test (default . ,rest))
-       (let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                       info)))
-         (fold (cut switch->info #f label count <> i <>) info (cons `(case ,test) `(default ,@rest)))))
-      ((case ,test ,statement)
-       (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                        info))
-              (info (switch->info #f label count `(case ,test) i info))
-              (info (append-text info (jump next-clause-label)))
-              (info (append-text info (wrap-as `((#:label ,body-label))))))
-         (ast->info statement info)))
-      ((case ,test (case . ,case1) . ,rest)
-       (let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                       info)))
-         (fold (cut switch->info #f label count <> i <>) info (cons `(case ,test) `((case ,@case1) ,@rest)))))
-      ((default (case . ,case1) . ,rest)
-       (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                        info))
-               (info (if last? info
-                         (append-text info (jump next-clause-label))))
-              (info (append-text info (wrap-as `((#:label ,default-label)))))
-              (info (append-text info (jump body-label))))
-         (fold (cut switch->info #f label count <> i <>) info `((case ,@case1) ,@rest))))
-      (default
-        (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                         info))
-               (info (if last? info
-                         (append-text info (jump next-clause-label))))
-               (info (append-text info (wrap-as `((#:label ,default-label))))))
-          (append-text info (jump body-label))))
-      ((default ,statement)
-       (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                        info))
-              (info (if last? info
-                        (append-text info (jump next-clause-label))))
-              (info (append-text info (wrap-as `((#:label ,body-label)))))
-              (info (append-text info (wrap-as `((#:label ,default-label))))))
-         (ast->info statement info)))
-      ((default ,statement ,rest)
-       (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
-                        info))
-              (info (if last? info
-                        (append-text info (jump next-clause-label))))
-              (info (append-text info (wrap-as `((#:label ,body-label)))))
-              (info (append-text info (wrap-as `((#:label ,default-label))))))
-         (fold ast->info (ast->info statement info) rest)))
-      ((labeled-stmt (ident ,goto-label) ,statement)
-       (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" goto-label)))))))
-         (switch->info clause? label count statement i info)))
-      (_ (ast->info o info)))))
-
-(define (global->static function)
-  (lambda (o)
-    (cons (car o) (set-field (cdr o) (global:function) function))))
-
-(define (decl->info info o)
-  (pmatch o
-    (((decl-spec-list (type-spec ,type)) (init-declr-list . ,inits))
-     (let* ((info (type->info type #f info))
-            (type (ast->type type info)))
-       (fold (cut init-declr->info type <> <>) info (map cdr inits))))
-    (((decl-spec-list (type-spec ,type)))
-     (type->info type #f info))
-    (((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ident ,name))))
-     (let* ((info (type->info type name info))
-            (type (ast->type type info)))
-       (clone info #:types (acons name type (.types info)))))
-    ;; FIXME: recursive types, pointer, array
-    (((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count))))
-     (let* ((info (type->info type name info))
-            (type (ast->type type info))
-            (count (expr->number info count))
-            (type (make-c-array type count)))
-       (clone info #:types (acons name type (.types info)))))
-    (((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
-     (let* ((info (type->info type name info))
-            (type (ast->type type info))
-            (rank (pointer->rank pointer))
-            (type (rank+= type rank)))
-       (clone info #:types (acons name type (.types info)))))
-    (((decl-spec-list (stor-spec (,store)) (type-spec ,type)) (init-declr-list . ,inits))
-     (let* ((info (type->info type #f info))
-            (type (ast->type type info))
-            (function (.function info)))
-       (if (not function) (fold (cut init-declr->info type <> <>) info (map cdr inits))
-           (let* ((tmp (clone info #:function #f #:globals '()))
-                  (tmp (fold (cut init-declr->info type <> <>) tmp (map cdr inits)))
-                  (statics (map (global->static function) (.globals tmp)))
-                  (strings (filter string-global? (.globals tmp))))
-             (clone info #:globals (append (.globals info) strings)
-                    #:statics (append statics (.statics info)))))))
-    (((decl-spec-list (stor-spec (,store)) (type-spec ,type)))
-     (type->info type #f info))
-    (((@ . _))
-     (stderr "decl->info: skip: ~s\n" o)
-     info)
-    (_ (error "decl->info: not supported:" o))))
-
-(define (ast->name o)
-  (pmatch o
-    ((ident ,name) name)
-    ((array-of ,array . ,_) (ast->name array))
-    ((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) . _) name)
-    ((ptr-declr ,pointer ,decl . ,_) (ast->name decl))
-    ((ptr-declr ,pointer (ident ,name)) name)
-    (_ (error "ast->name not supported: " o))))
-
-(define (init-declr->count info o)
-  (pmatch o
-    ((array-of (ident ,name) ,count) (expr->number info count))
-    (_ #f)))
-
-(define (init->accu o info)
-  (pmatch o
-    ((initzer-list (initzer ,expr)) (expr->accu expr info))
-    (((#:string ,string))
-     (append-text info (list (i386:label->accu `(#:string ,string)))))
-    ((,number . _) (guard (number? number))
-     (append-text info (wrap-as (i386:value->accu 0))))
-    ((,c . ,_) (guard (char? c)) info)
-    (_ (expr->accu o info))))
-
-(define (init-struct-field local field init info)
-  (let* ((offset (field-offset info (local:type local) (car field)))
-         (size (field:size field))
-         (empty (clone info #:text '())))
-    (clone info #:text
-           (append
-            (.text info)
-            (local->accu local)
-            (wrap-as (append (i386:accu->base)))
-            (wrap-as (append (i386:push-base)))
-            (.text (expr->accu init empty))
-            (wrap-as (append (i386:pop-base)))
-            (wrap-as (case size
-                       ((1) (i386:byte-accu->base-mem+n offset))
-                       ((2) (i386:word-accu->base-mem+n offset))
-                       (else (i386:accu->base-mem+n offset))))))))
-
-(define (init-array-entry local index init info)
-  (let* ((type (local:type local))
-         (size (cond ((pointer? type) %pointer-size)
-                     ((and (c-array? type) ((compose pointer? c-array:type) type)) %pointer-size)
-                     ((c-array? type) ((compose type:size c-array:type) type))
-                     (else (type:size type))))
-         (offset (* index size))
-         (empty (clone info #:text '())))
-    (clone info #:text
-           (append
-            (.text info)
-            (local->accu local)
-            (wrap-as (append (i386:accu->base)))
-            (wrap-as (append (i386:push-base)))
-            (.text (expr->accu init empty))
-            (wrap-as (append (i386:pop-base)))
-            (wrap-as (case size
-                       ((1) (i386:byte-accu->base-mem+n offset))
-                       ((2) (i386:word-accu->base-mem+n offset))
-                       (else (i386:accu->base-mem+n offset))))))))
-
-
-(define (init-local local o n info)
-  (pmatch o
-    (#f info)
-    ((initzer ,init)
-     (init-local local init n info))
-    ((initzer-list ,init)
-     (init-local local init n info))
-    ((initzer-list . ,inits)
-     (let ((struct? (structured-type? local)))
-       (cond (struct?
-              (let ((fields ((compose struct->init-fields local:type) local)))
-                (fold (cut init-struct-field local <> <> <>) info fields (append inits (map (const '(p-expr (fixed "22"))) (iota (max 0 (- (length fields) (length inits)))))))))
-             (else (fold (cut init-local local <> <> <>) info inits (iota (length inits)))))))
-    (,string (guard (string? string))
-             (let ((inits (string->list string)))
-               (fold (cut init-array-entry local <> <> <>) info (iota (length inits)) inits)))
-    (((initzer (initzer-list . ,inits)))
-     (fold (cut init-array-entry local <> <> <>) info (iota (length inits)) inits))
-    (() info)
-    (_ (let ((info (init->accu o info)))
-         (append-text info (accu->local+n-text local n))))))
-
-(define (local->info type name o init info)
-  (let* ((locals (.locals info))
-         (id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
-                 (1+ (local:id (cdar locals)))))
-         (local (make-local-entry name type id))
-         (pointer (->rank (cdr local)))
-         (array? (or (and (c-array? type) type)
-                     (and (pointer? type)
-                          (c-array? (pointer:type type))
-                          (pointer:type type))
-                     (and (pointer? type)
-                          (pointer? (pointer:type type))
-                          (c-array? (pointer:type (pointer:type type)))
-                          (pointer:type (pointer:type type)))))
-         (struct? (structured-type? type))
-         (size (->size type))
-         (string (and array? (array-init->string init)))
-         (init (or string init))
-         (local (if (not array?) local
-                    (let ((size (or (and string (max size (1+ (string-length string))))
-                                    size)))
-                      (make-local-entry name type (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))))
-         (local (if struct? (make-local-entry name type (+ (local:id (cdr local)) (quotient (+ size 3) 4)))
-                    local))
-         (locals (cons local locals))
-         (info (clone info #:locals locals))
-         (local (cdr local)))
-    (init-local local init 0 info)))
-
-(define (global->info type name o init info)
-  (let* ((rank (->rank type))
-         (size (->size type))
-         (data (cond ((not init) (string->list (make-string size #\nul)))
-                     ((c-array? type)
-                      (let* ((string (array-init->string init))
-                             (size (or (and string (max size (1+ (string-length string))))
-                                       size))
-                             (data  (or (and=> string string->list)
-                                        (array-init->data type size init info))))
-                        (append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))
-                     ((structured-type? type)
-                      (let ((data (init->data type init info)))
-                        (append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))
-                     (else
-                      (let ((data (init->data type init info)))
-                        (append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))))
-         (global (make-global-entry name type data)))
-    (clone info #:globals (append (.globals info) (list global)))))
-
-(define (array-init-element->data type o info)
-  (pmatch o
-    ((initzer (p-expr (string ,string)))
-     `((#:string ,string)))
-    ((initzer (p-expr (fixed ,fixed)))
-     (int->bv type (expr->number info fixed)))
-    ((initzer (initzer-list . ,inits))
-      (if (structured-type? type)
-          (let* ((fields (map cdr (struct->init-fields type)))
-                 (missing (max 0 (- (length fields) (length inits))))
-                 (inits (append inits
-                                (map (const '(fixed "0")) (iota missing)))))
-            (map (cut init->data <> <> info) fields inits))
-          (begin
-            (stderr "array-init-element->data: oops:~s\n" o)
-            (stderr "type:~s\n" type)
-            (error "array-init-element->data: not supported: " o))))
-    (_ (init->data type o info))
-    (_ (error "array-init-element->data: not supported: " o))))
-
-(define (array-init->data type size o info)
-  (pmatch o
-    ((initzer (initzer-list . ,inits))
-     (let ((type (c-array:type type)))
-       (map (cut array-init-element->data type <> info) inits)))
-
-    (((initzer (initzer-list . ,inits)))
-     (array-init->data type size (car o) info))
-
-    ((initzer (p-expr (string ,string)))
-     (let ((data (string->list string)))
-       (if (not size) data
-           (append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))
-
-    (((initzer (p-expr (string ,string))))
-     (array-init->data type size (car o) info))
-
-    ((initzer (p-expr (string . ,strings)))
-     (let ((data (string->list (apply string-append strings))))
-       (if (not size) data
-           (append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))
-
-    (((initzer (p-expr (string . ,strings))))
-     (array-init->data type size (car o) info))
-
-    ((initzer (p-expr (fixed ,fixed)))
-     (int->bv type (expr->number info fixed)))
-
-    (() (string->list (make-string size #\nul)))
-    (_ (error "array-init->data: not supported: " o))))
-
-(define (array-init->string o)
-  (pmatch o
-    ((p-expr (string ,string)) string)
-    ((p-expr (string . ,strings)) (apply string-append strings))
-    ((initzer ,init) (array-init->string init))
-    (((initzer ,init)) (array-init->string init))
-    ((initzer-list (initzer (p-expr (char ,c))) . ,inits)
-     (list->string (map (lambda (i) (pmatch i
-                                      ((initzer (p-expr (char ,c))) ((compose car string->list) c))
-                                      ((initzer (p-expr (fixed ,fixed)))
-                                       (let ((value (cstring->int fixed)))
-                                         (if (and (>= value 0) (<= value 255))
-                                             (integer->char value)
-                                             (error "array-init->string: not supported:" i o))))
-                                      (_ (error "array-init->string: not supported:" i o))))
-                        (cdr o))))
-    (_ #f)))
-
-(define (init-declr->info type o info)
-  (pmatch o
-    (((ident ,name))
-     (if (.function info) (local->info type name o #f info)
-         (global->info type name o #f info)))
-    (((ident ,name) (initzer ,init))
-     (let* ((strings (init->strings init info))
-            (info (if (null? strings) info
-                      (clone info #:globals (append (.globals info) strings)))))
-       (if (.function info) (local->info type name o init info)
-           (global->info type name o init info))))
-    (((ftn-declr (ident ,name) . ,_))
-     (let ((functions (.functions info)))
-       (if (member name functions) info
-           (let* ((type (ftn-declr:get-type info `(ftn-declr (ident ,name) ,@_)))
-                  (function (make-function name type  #f)))
-             (clone info #:functions (cons (cons name function) functions))))))
-    (((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) ,param-list) ,init)
-     (let* ((rank (pointer->rank pointer))
-            (type (rank+= type rank)))
-       (if (.function info) (local->info type name o init info)
-           (global->info type name o init info))))
-    (((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) ,param-list))
-     (let* ((rank (pointer->rank pointer))
-            (type (rank+= type rank)))
-       (if (.function info) (local->info type name o '() info)
-           (global->info type name o '() info))))
-    (((ptr-declr ,pointer . ,_) . ,init)
-     (let* ((rank (pointer->rank pointer))
-            (type (rank+= type rank)))
-       (init-declr->info type (append _ init) info)))
-    (((array-of (ident ,name) ,count) . ,init)
-     (let* ((strings (init->strings init info))
-            (info (if (null? strings) info
-                      (clone info #:globals (append (.globals info) strings))))
-            (count (expr->number info count))
-            (type (make-c-array type count)))
-       (if (.function info) (local->info type name o init info)
-           (global->info type name o init info))))
-    (((array-of (ident ,name)) . ,init)
-     (let* ((strings (init->strings init info))
-            (info (if (null? strings) info
-                      (clone info #:globals (append (.globals info) strings))))
-            (count (length (cadar init)))
-            (type (make-c-array type count)))
-       (if (.function info) (local->info type name o init info)
-           (global->info type name o init info))))
-    ;; FIXME: recursion
-    (((array-of (array-of (ident ,name) ,count1) ,count) . ,init)
-     (let* ((strings (init->strings init info))
-            (info (if (null? strings) info
-                      (clone info #:globals (append (.globals info) strings))))
-            (count (expr->number info count))
-            (count1 (expr->number info count1))
-            (type (make-c-array (make-c-array type count1) count)))
-       (if (.function info) (local->info type name o init info)
-           (global->info type name o init info))))
-    (_ (error "init-declr->info: not supported: " o))))
-
-(define (enum-def-list->constants constants fields)
-  (let loop ((fields fields) (i 0) (constants constants))
-    (if (pair? fields)
-        (let ((field (car fields)))
-          (mescc:trace (cadr (cadr field)) " <e>")))
-    (if (null? fields) constants
-        (let* ((field (car fields))
-               (name (pmatch field
-                       ((enum-defn (ident ,name) . _) name)))
-               (i (pmatch field
-                    ((enum-defn ,name) i)
-                    ((enum-defn ,name ,exp) (expr->number #f exp))
-                    (_ (error "not supported enum field=~s\n" field)))))
-          (loop (cdr fields)
-                (1+ i)
-                (append constants (list (ident->constant name i))))))))
-
-(define (init->data type o info)
-  (pmatch o
-    ((p-expr ,expr) (init->data type expr info))
-    ((fixed ,fixed) (int->bv type (expr->number info o)))
-    ((char ,char) (int->bv type (char->integer (string-ref char 0))))
-    ((string ,string) `((#:string ,string)))
-    ((string . ,strings) `((#:string ,(string-join strings ""))))
-    ((ident ,name) (let ((var (ident->variable info name)))
-                     `((#:address ,var))))
-    ((initzer-list . ,inits)
-     (cond ((structured-type? type)
-            (map (cut init->data <> <> info) (map cdr (struct->init-fields type)) inits))
-           ((c-array? type)
-            (let ((size (->size type)))
-             (array-init->data type size `(initzer ,o) info)))
-           (else
-            (append-map (cut init->data type <> info) inits))))
-    (((initzer (initzer-list . ,inits)))
-     (init->data type `(initzer-list . ,inits) info))
-    ((ref-to (p-expr (ident ,name)))
-     (let ((var (ident->variable info name)))
-       `((#:address ,var))))
-    ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
-     (let* ((type (ast->type struct info))
-            (offset (field-offset info type field))
-            (base (cstring->int base)))
-       (int->bv type (+ base offset))))
-    ((,char . _) (guard (char? char)) o)
-    ((,number . _) (guard (number? number))
-     (append (map int->bv type o)))
-    ((initzer ,init) (init->data type init info))
-    (((initzer ,init)) (init->data type init info))
-    ((cast _ ,expr) (init->data type expr info))
-    (() '())
-    (_ (let ((number (try-expr->number info o)))
-         (cond (number (int->bv type number))
-               (else (error "init->data: not supported: " o)))))))
-
-(define (int->bv type o)
-  (let ((size (->size type)))
-    (case size
-      ;;((1) (int->bv8 o))
-      ;;((2) (int->bv16 o))
-      (else (int->bv32 o)))))
-
-(define (init->strings o info)
-  (let ((globals (.globals info)))
-    (pmatch o
-      ((p-expr (string ,string))
-       (let ((g `(#:string ,string)))
-         (if (assoc g globals) '()
-             (list (string->global-entry string)))))
-      ((p-expr (string . ,strings))
-       (let* ((string (string-join strings ""))
-              (g `(#:string ,string)))
-         (if (assoc g globals) '()
-             (list (string->global-entry string)))))
-      (((initzer (initzer-list . ,init)))
-       (append-map (cut init->strings <> info) init))
-      ((initzer ,init)
-       (init->strings init info))
-      (((initzer ,init))
-       (init->strings init info))
-      ((initzer-list . ,init)
-       (append-map (cut init->strings <> info) init))
-      (_ '()))))
-
-(define (type->info o name info)
-  (pmatch o
-
-    ((enum-def (ident ,name) (enum-def-list . ,fields))
-     (mescc:trace name " <t>")
-     (let* ((type-entry (enum->type-entry name fields))
-            (constants (enum-def-list->constants (.constants info) fields)))
-       (clone info
-              #:types (cons type-entry (.types info))
-              #:constants (append constants (.constants info)))))
-
-    ((enum-def (enum-def-list . ,fields))
-     (mescc:trace name " <t>")
-     (let* ((type-entry (enum->type-entry name fields))
-            (constants (enum-def-list->constants (.constants info) fields)))
-       (clone info
-              #:types (cons type-entry (.types info))
-              #:constants (append constants (.constants info)))))
-
-    ((struct-def (field-list . ,fields))
-     (mescc:trace name " <t>")
-     (let* ((info (fold field->info info fields))
-            (type-entry (struct->type-entry name (append-map (struct-field info) fields))))
-       (clone info #:types (cons type-entry (.types info)))))
-
-    ((struct-def (ident ,name) (field-list . ,fields))
-     (mescc:trace name " <t>")
-     (let* ((info (fold field->info info fields))
-            (type-entry (struct->type-entry name (append-map (struct-field info) fields))))
-       (clone info #:types (cons type-entry (.types info)))))
-
-    ((union-def (ident ,name) (field-list . ,fields))
-     (mescc:trace name " <t>")
-     (let ((type-entry (union->type-entry name (append-map (struct-field info) fields))))
-       (clone info #:types (cons type-entry (.types info)))))
-
-    ((union-def (field-list . ,fields))
-     (mescc:trace name " <t>")
-     (let ((type-entry (union->type-entry name (append-map (struct-field info) fields))))
-       (clone info #:types (cons type-entry (.types info)))))
-
-    ((enum-ref . _) info)
-    ((struct-ref . _) info)
-    ((typename ,name) info)
-    ((union-ref . _) info)
-    ((fixed-type . _) info)
-    ((float-type . _) info)
-    ((void) info)
-
-    (_ ;;(error "type->info: not supported:" o)
-     (stderr "type->info: not supported: ~s\n" o)
-     info
-     )))
-
-(define (field->info o info)
-  (pmatch o
-    ((comp-decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))) . _)
-     (let* ((fields (append-map (struct-field info) fields))
-            (struct (make-type 'struct (apply + (map field:size fields)) fields)))
-       (clone info #:types (acons `(tag ,name) struct (.types info)))))
-    ((comp-decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields)))) . _)
-     (let* ((fields (append-map (struct-field info) fields))
-            (union (make-type 'union (apply + (map field:size fields)) fields)))
-       (clone info #:types (acons `(tag ,name) union (.types info))) ))
-    ((comp-decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))) . _)
-     (let ((constants (enum-def-list->constants (.constants info) fields)))
-       (clone info
-              #:constants (append constants (.constants info)))))
-    ((comp-decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))) . _)
-     (let ((constants (enum-def-list->constants (.constants info) fields))
-           (type-entry (enum->type-entry name fields)))
-       (clone info
-              #:types (cons type-entry (.types info))
-              #:constants (append constants (.constants info)))))
-    (_ info)))
-
-;;;\f fctn-defn
-(define (param-decl:get-name o)
-  (pmatch o
-    ((ellipsis) #f)
-    ((param-decl (decl-spec-list (type-spec (void)))) #f)
-    ((param-decl _ (param-declr ,ast)) (ast->name ast))
-    (_ (error "param-decl:get-name not supported:" o))))
-
-(define (fctn-defn:get-name o)
-  (pmatch o
-    ((_ (ftn-declr (ident ,name) _) _) name)
-    ((_ (ptr-declr (pointer . _) (ftn-declr (ident ,name) _)) _) name)
-    (_ (error "fctn-defn:get-name not supported:" o))))
-
-(define (param-decl:get-type o info)
-  (pmatch o
-    ((ellipsis) #f)
-    ((param-decl (decl-spec-list ,type)) (ast->type type info))
-    ((param-decl (decl-spec-list (type-spec ,type)) (param-declr (ptr-declr ,pointer (ident ,name))))
-     (let ((rank (pointer->rank pointer)))
-       (rank+= (ast->type type info) rank)))
-    ((param-decl (decl-spec-list ,type) (param-declr (ptr-declr ,pointer (array-of _))))
-     (let ((rank (pointer->rank pointer)))
-       (rank+= (ast->type type info) (1+ rank))))
-    ((param-decl ,type _) (ast->type type info))
-    (_ (error "param-decl:get-type not supported:" o))))
-
-(define (fctn-defn:get-formals o)
-  (pmatch o
-    ((_ (ftn-declr _ ,formals) _) formals)
-    ((_ (ptr-declr (pointer . _) (ftn-declr _ ,formals)) _) formals)
-    (_ (error "fctn-defn->formals: not supported:" o))))
-
-(define (formal->text n)
-  (lambda (o i)
-    ;;(i386:formal i n)
-    '()
-    ))
-
-(define (param-list->text o)
-  (pmatch o
-    ((param-list . ,formals)
-     (let ((n (length formals)))
-       (wrap-as (append (i386:function-preamble)
-                        (append-map (formal->text n) formals (iota n))
-                        (i386:function-locals)))))
-    (_ (error "param-list->text: not supported: " o))))
-
-(define (param-list->locals o info)
-  (pmatch o
-    ((param-list . ,formals)
-     (let ((n (length formals)))
-       (map make-local-entry
-            (map param-decl:get-name formals)
-            (map (cut param-decl:get-type <> info) formals)
-            (iota n -2 -1))))
-    (_ (error "param-list->locals: not supported:" o))))
-
-(define (fctn-defn:get-type info o)
-  (pmatch o
-    (((decl-spec-list (type-spec ,type)) (ptr-declr ,pointer . _) ,statement)
-     (let* ((type (ast->type type info))
-            (rank (ptr-declr->rank pointer)))
-       (if (zero? rank) type
-           (make-pointer type rank))))
-    (((decl-spec-list (type-spec ,type)) . _)
-     (ast->type type info))
-    (((decl-spec-list (stor-spec ,store) (type-spec ,type)) . _)
-     (ast->type type info))
-
-    ;; (((decl-spec-list (stor-spec ,store) (type-spec ,type)) (ftn-declr (ident _) _) _)
-    ;;  (ast->type type info))
-    ;; (((decl-spec-list (stor-spec ,store) (type-spec ,type)) (ptr-declr ,pointer (ftn-declr (ident _) _)) _)
-    ;;  (ast->type type info))
-
-    (_ (error "fctn-defn:get-type: not supported:" o))))
-
-(define (ftn-declr:get-type info o)
-  (pmatch o
-    ((ftn-declr (ident _) . _) #f)
-    (_ (error "fctn-decrl:get-type: not supported:" o))))
-
-(define (fctn-defn:get-statement o)
-  (pmatch o
-    ((_ (ftn-declr (ident _) _) ,statement) statement)
-    ((_ (ptr-declr (pointer . _) (ftn-declr (ident _) . _)) ,statement) statement)
-    (_ (error "fctn-defn:get-statement: not supported: " o))))
-
-(define (fctn-defn->info o info)
-  (define (assert-return text)
-    (let ((return (wrap-as (i386:ret))))
-      (if (equal? (list-tail text (- (length text) (length return))) return) text
-          (append text return))))
-  (let ((name (fctn-defn:get-name o)))
-    (mescc:trace name)
-    (let* ((type (fctn-defn:get-type info o))
-           (formals (fctn-defn:get-formals o))
-           (text (param-list->text formals))
-           (locals (param-list->locals formals info))
-           (statement (fctn-defn:get-statement o))
-           (function (cons name (make-function name type '())))
-           (functions (cons function (.functions info)))
-           (info (clone info #:locals locals #:function name #:text text #:functions functions #:statics '()))
-           (info (ast->info statement info))
-           (locals (.locals info))
-           (local (and (pair? locals) (car locals)))
-           (count (and=> local (compose local:id cdr)))
-           (stack (and count (* count 4))))
-      (if (and stack (getenv "MESC_DEBUG")) (stderr "        stack: ~a\n" stack))
-      (clone info
-             #:function #f
-             #:globals (append (.statics info) (.globals info))
-             #:statics '()
-             #:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info))))))))))
-
-;; exports
-
-(define* (c99-ast->info o)
-  (ast->info o (make <info> #:types i386:type-alist)))
-
-(define* (c99-input->ast #:key (defines '()) (includes '()))
-  (stderr "parsing: input\n")
-  ((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:defines defines #:includes includes)))
-
-(define* (c99-input->info #:key (defines '()) (includes '()))
-  (lambda ()
-    (let* ((info (make <info> #:types i386:type-alist))
-           (ast (c99-input->ast #:defines defines #:includes includes))
-           (foo (stderr "compiling: input\n"))
-           (info (ast->info ast info))
-           (info (clone info #:text '() #:locals '())))
-      info)))
-
-(define* (info->object o)
-  (stderr "compiling: object\n")
-  `((functions . ,(filter (compose pair? function:text cdr) (.functions o)))
-    (globals . ,(.globals o))))
-
-(define* (c99-input->elf #:key (defines '()) (includes '()))
-  ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
-
-(define* (c99-input->object #:key (defines '()) (includes '()))
-  ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))
diff --git a/module/language/c99/compiler.scm b/module/language/c99/compiler.scm
deleted file mode 100644 (file)
index 0604bfc..0000000
+++ /dev/null
@@ -1,61 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(define-module (language c99 compiler)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9 gnu)
-  #:use-module (srfi srfi-26)
-  #:use-module (system base pmatch)
-  #:use-module (ice-9 optargs)
-  #:use-module (ice-9 pretty-print)
-  #:use-module (nyacc lang c99 parser)
-  ;;#:use-module (nyacc lang c99 pprint)
-  #:use-module (mes guile)
-  #:use-module (mes as)
-  #:use-module (mes as-i386)
-  #:use-module (mes elf)
-  #:use-module (mes M1)
-  #:use-module (language c99 info)
-  #:export (c99-ast->info
-            c99-input->ast
-            c99-input->elf
-            c99-input->info
-            c99-input->object
-            info->object))
-
-(cond-expand
- (guile-2
-  (use-modules (nyacc lang c99 pprint)))
- (guile
-  (debug-set! stack 0)
-  (use-modules (ice-9 optargs))
-  (use-modules (ice-9 syncase)))
- ;; guile-1.8 does not have (sxml match), short-circuit me
- (define* (pretty-print-c99 tree
-                            #:optional (port (current-output-port))
-                            #:key ugly per-line-prefix (basic-offset 2))
-   (write tree port))
- (mes))
-
-(include-from-path "language/c99/compiler.mes")
diff --git a/module/language/c99/info.mes b/module/language/c99/info.mes
deleted file mode 100644 (file)
index ec89743..0000000
+++ /dev/null
@@ -1,28 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(mes-use-module (srfi srfi-9))
-(mes-use-module (srfi srfi-9 gnu))
-(include-from-path "language/c99/info.scm")
-
diff --git a/module/language/c99/info.scm b/module/language/c99/info.scm
deleted file mode 100644 (file)
index 84f1c3a..0000000
+++ /dev/null
@@ -1,265 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; info.scm defines [Guile] record data types for compiler.mes
-
-;;; Code:
-
-(define-module (language c99 info)
-  #:use-module (ice-9 optargs)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-9 gnu)
-  #:use-module (srfi srfi-26)
-  #:export (<info>
-            make
-            make-<info>
-            info?
-
-            .types
-            .constants
-            .functions
-            .globals
-            .locals
-            .function
-            .statics
-            .text
-            .post
-            .break
-            .continue
-
-            <type>
-            make-type
-            type?
-            type:type
-            type:size
-            type:pointer
-            type:description
-
-            <c-array>
-            make-c-array
-            c-array?
-            c-array:type
-            c-array:count
-
-            <pointer>
-            make-pointer
-            pointer?
-            pointer:type
-            pointer:rank
-
-            <bit-field>
-            make-bit-field
-            bit-field?
-            bit-field:type
-            bit-field:bit
-            bit-field:bits
-
-            <var>
-            var:name
-            var:type
-            var:pointer
-            var:c-array
-
-            <global>
-            make-global
-            global?
-            global:name
-            global:type
-            global:pointer
-            global:c-array
-            global:var
-            global:value
-            global:function
-            global->string
-
-            <local>
-            make-local
-            local?
-            local:type
-            local:pointer
-            local:c-array
-            local:var
-            local:id
-
-            <function>
-            make-function
-            function?
-            function:name
-            function:type
-            function:text
-            function->string
-
-            ->type
-            ->rank
-            rank--
-            rank++
-            rank+=
-            structured-type?))
-
-(cond-expand
- (guile-2)
- (guile
-  (use-modules (ice-9 syncase))
-  (use-modules (ice-9 optargs)))
- (mes
-  (mes-use-module (mes optargs))))
-
-(define-immutable-record-type <info>
-  (make-<info> types constants functions globals locals statics function text post break continue)
-  info?
-  (types .types)
-  (constants .constants)
-  (functions .functions)
-  (globals .globals)
-  (locals .locals)
-  (statics .statics)
-  (function .function)
-  (text .text)
-  (post .post)
-  (break .break)
-  (continue .continue))
-
-(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '()))
-  (make-<info> types constants functions globals locals statics function text post break continue))
-
-;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
-;;           (make-type 'enum 4 0 fields)
-;;           (make-type 'struct (apply + (map field:size fields)) 0 fields)
-
-(define-immutable-record-type <type>
-  (make-type type size description)
-  type?
-  (type type:type)
-  (size type:size)
-  (description type:description))
-
-(define-immutable-record-type <c-array>
-  (make-c-array type count)
-  c-array?
-  (type c-array:type)
-  (count c-array:count))
-
-(define-immutable-record-type <pointer>
-  (make-pointer type rank)
-  pointer?
-  (type pointer:type)
-  (rank pointer:rank))
-
-(define-immutable-record-type <bit-field>
-  (make-bit-field type bit bits)
-  bit-field?
-  (type bit-field:type)
-  (bit bit-field:bit)
-  (bits bit-field:bits))
-
-(define-immutable-record-type <var>
-  (make-var name type function id value)
-  var?
-  (name var:name)
-  (type var:type)                       ; <type>
-  (function var:function)
-  (id var:id)
-  (value var:value))
-
-(define-immutable-record-type <global>
-  (make-global- name type var value function)
-  global?
-  (name global:name)
-  (type global:type)
-  (var global:var)                      ; <var>
-
-  (value global:value)
-  (function global:function))
-
-(define (make-global name type value function)
-  (make-global- name type (make-var name type function #f value) value function))
-
-(define (global->string o)
-  (or (and=> (global:function o) (cut string-append <> "-" (global:name o)))
-      (global:name o)))
-
-(define-immutable-record-type <local>
-  (make-local- type var id)
-  local?
-  (type local:type)
-  (var local:var)                       ; <var>
-
-  (id local:id))
-
-(define (make-local name type id)
-  (make-local- type (make-var name type #f id #f) id))
-
-(define-immutable-record-type <function>
-  (make-function name type text)
-  function?
-  (name function:name)
-  (type function:type)
-  (text function:text))
-
-(define (function->string o)
-  (function:name o))
-
-(define (structured-type? o)
-  (cond ((type? o) (memq (type:type o) '(struct union)))
-        ((global? o) ((compose structured-type? global:type) o))
-        ((local? o) ((compose structured-type? local:type) o))
-        ((and (pair? o) (eq? (car o) 'tag))) ;; FIXME: enum?
-        (else #f)))
-
-(define (->type o)
-  (cond ((type? o) o)
-        ((bit-field? o) o)
-        ((pointer? o) ((compose ->type pointer:type) o))
-        ((c-array? o) ((compose ->type c-array:type) o))
-        ((and (pair? o) (eq? (car o) 'tag)) o)
-        ;; FIXME
-        (#t
-         (format (current-error-port) "->type--: not a <type>: ~s\n" o)
-         (make-type 'builtin 4 #f))
-        (else (error "->type: not a <type>:" o))))
-
-(define (->rank o)
-  (cond ((type? o) 0)
-        ((pointer? o) (pointer:rank o))
-        ((c-array? o) (1+ ((compose ->rank c-array:type) o)))
-        ((local? o) ((compose ->rank local:type) o))
-        ((global? o) ((compose ->rank global:type) o))
-        ((bit-field? o) 0)
-        ;; FIXME
-        (#t
-         (format (current-error-port) "->rank: not a type: ~s\n" o)
-         0)
-        (else (error "->rank: not a <type>:" o))))
-
-(define (rank-- o)
-  (cond ((and (pointer? o) (= (pointer:rank o) 1)) (pointer:type o))
-        ((pointer? o) (set-field o (pointer:rank) (1- (pointer:rank o))))
-        ((c-array? o) (c-array:type o))
-        ;; FIXME
-        (#t (format (current-error-port) "rank--: not a pointer: ~s\n" o)
-              o)
-        (else (error "rank--: not a pointer" o))))
-
-(define (rank+= o i)
-  (cond ((pointer? o) (set-field o (pointer:rank) (+ i (pointer:rank o))))
-        (else (make-pointer o i))))
-
-(define (rank++ o)
-  (rank+= o 1))
diff --git a/module/mes/M1.mes b/module/mes/M1.mes
deleted file mode 100644 (file)
index 107342a..0000000
+++ /dev/null
@@ -1,215 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; M1.mes produces stage0' M1 object format
-
-;;; Code:
-
-(cond-expand
- (guile)
- (mes
-  (mes-use-module (srfi srfi-1))
-  (mes-use-module (srfi srfi-26))
-  (mes-use-module (mes as))
-  (mes-use-module (mes elf))
-  (mes-use-module (mes optargs))
-  (mes-use-module (mes pmatch))
-  (mes-use-module (language c99 info))))
-
-(define (logf port string . rest)
-  (apply format (cons* port string rest))
-  (force-output port)
-  #t)
-
-(define (stderr string . rest)
-  (apply logf (cons* (current-error-port) string rest)))
-
-(define (pke . stuff)
-  (newline (current-error-port))
-  (display ";;; " (current-error-port))
-  (write stuff (current-error-port))
-  (newline (current-error-port))
-  (car (last-pair stuff)))
-
-(define (objects->M1 file-name objects)
-  ((compose (cut object->M1 file-name <>) merge-objects) objects))
-
-(define (object->elf file-name o)
-  ((compose M1->elf (cut object->M1 file-name <>)) o))
-
-(define (objects->elf file-name objects)
-  ((compose M1->elf (cut object->M1 file-name <>) merge-objects) objects))
-
-(define (merge-objects objects)
-  (let loop ((objects (cdr objects)) (object (car objects)))
-    (if (null? objects) object
-        (loop (cdr objects)
-              `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
-                (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
-
-(define (alist-add a b)
-  (let* ((b-keys (map car b))
-         (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
-         (a-keys (map car a)))
-    (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
-
-(define (hex2:address o)
-  (string-append "&" o))
-
-(define (hex2:offset o)
-  (string-append "%" o))
-
-(define (hex2:offset1 o)
-  (string-append "!" o))
-
-(define hex? #t)
-
-(define (hex2:immediate o)
-  (if hex? (string-append "%0x" (dec->hex o))
-      (string-append "%" (number->string o))))
-
-(define (hex2:immediate1 o)
-  (if hex? (string-append "!0x" (dec->hex o))
-      (string-append "!" (number->string o))))
-
-(define* (display-join o #:optional (sep ""))
-  (let loop ((o o))
-    (when (pair? o)
-      (display (car o))
-      (if (pair? (cdr o))
-          (display sep))
-      (loop (cdr o)))))
-
-(define (object->M1 file-name o)
-  (stderr "dumping M1: object\n")
-  (let* ((functions (assoc-ref o 'functions))
-         (function-names (map car functions))
-         (globals (assoc-ref o 'globals))
-         (global-names (map car globals))
-         (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
-    (define (string->label o)
-      (let ((index (list-index (lambda (s) (equal? s o)) strings)))
-        (if index
-            (string-append "_string_" file-name "_" (number->string index))
-            (error "no such string:" o))))
-    (define (text->M1 o)
-      (cond
-       ((char? o) (text->M1 (char->integer o)))
-       ((string? o) o)
-       ((symbol? o) (symbol->string o))
-       ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
-                      (if hex? (string-append "!0x"
-                                              (if (and (>= o 0) (< o 16)) "0" "")
-                                              (number->string o 16))
-                          (string-append "!" (number->string o)))))
-       ((and (pair? o) (keyword? (car o)))
-        (pmatch o
-          ;; FIXME
-          ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
-          ((#:address (#:address ,address)) (guard (string? address))
-           (hex2:address address))
-          ((#:address (#:address ,global)) (guard (global? global))
-           (hex2:address (global->string global)))
-          ((#:address ,function) (guard (function? function))
-           (hex2:address (function->string function)))
-          ((#:address ,number) (guard (number? number))
-           (string-join (map text->M1 (int->bv32 number))))
-          ((#:string ,string)
-           (hex2:address (string->label o)))
-          ((#:address ,address) (guard (string? address)) (hex2:address address))
-          ((#:address ,global) (guard (global? global))
-           (hex2:address (global->string global)))
-          ((#:offset ,offset) (hex2:offset offset))
-          ((#:offset1 ,offset1) (hex2:offset1 offset1))
-          ((#:immediate ,immediate) (hex2:immediate immediate))
-          ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
-          (_ (error "text->M1 no match o" o))))
-       ((pair? o) (string-join (map text->M1 o)))))
-    (define (write-function o)
-      (let ((name (car o))
-            (text (function:text (cdr o))))
-        (define (line->M1 o)
-          (cond ((eq? (car o) #:label)
-                 (display (string-append ":" (cadr o))))
-                ((eq? (car o) #:comment)
-                 (display "\t\t\t\t\t# ")
-                 (display (text->M1 (cadr o))))
-                ((or (string? (car o)) (symbol? (car o)))
-                 (display "\t" )
-                 (display-join (map text->M1 o) " "))
-                (else (error "line->M1 invalid line:" o)))
-          (newline))
-        (display (string-append "    :" name "\n") (current-error-port))
-        (display (string-append "\n\n:" name "\n"))
-        (for-each line->M1 (apply append text))))
-    (define (write-global o)
-      (define (labelize o)
-        (if (not (string? o)) o
-            (let* ((label o)
-                   (function? (member label function-names))
-                   (string-label (string->label label))
-                   (string? (not (equal? string-label "_string_#f"))))
-              (cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
-                    ((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
-                    (else (string-append "&" label))))))
-      (define (display-align size)
-        (let ((alignment (- 4 (modulo size 4))))
-          (when (> 4 alignment 0)
-            (display " ")
-            (display-join (map text->M1 (map (const 0) (iota alignment))) " "))))
-      (let* ((label (cond
-                     ((and (pair? (car o)) (eq? (caar o) #:string))
-                      (string->label (car o)))
-                     ((global? (cdr o)) (global->string (cdr o)))
-                     (else (car o))))
-             (string? (string-prefix? "_string" label))
-             (foo (if (not (eq? (car (string->list label)) #\_))
-                      (display (string-append "    :" label "\n") (current-error-port))))
-             (data ((compose global:value cdr) o))
-             (data (filter-map labelize data))
-             (len (length data))
-             (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
-             (string-data (and string? (list-head data (1- (length data))))))
-        (display (string-append "\n:" label "\n"))
-        (if (and string-data
-                 (< len string-max)
-                 (char? (car data))
-                 (eq? (last data) #\nul)
-                 (not (find (cut memq <> '(#\")) string-data))
-                 (not (any (lambda (ch)
-                             (or (and (not (memq ch '(#\tab #\newline)))
-                                      (< (char->integer ch) #x20))
-                                 (>= (char->integer ch) #x80))) string-data)))
-            (let ((text string-data))
-              (display (string-append "\"" (list->string string-data) "\""))
-              (display-align (1+ (length string-data))))
-            (let ((text (map text->M1 data)))
-              (display-join  text " ")
-              (display-align (length text))))
-        (newline)))
-    (display "M1: functions\n" (current-error-port))
-    (for-each write-function (filter cdr functions))
-    (when (assoc-ref functions "main")
-      (display "\n\n:ELF_data\n") ;; FIXME
-      (display "\n\n:HEX2_data\n"))
-    (display "M1: globals\n" (current-error-port))
-    (for-each write-global globals)))
diff --git a/module/mes/M1.scm b/module/mes/M1.scm
deleted file mode 100644 (file)
index ab522ca..0000000
+++ /dev/null
@@ -1,44 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(define-module (mes M1)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-  #:use-module (system base pmatch)
-  #:use-module (mes guile)
-  #:use-module (mes as)
-  #:use-module (mes elf)
-  #:use-module (language c99 info)
-  #:export (object->M1
-            objects->M1
-            object->elf
-            objects->elf))
-
-(cond-expand
- (guile-2)
- (guile
-  (use-modules (ice-9 syncase)))
- (mes))
-
-(include-from-path "mes/M1.mes")
diff --git a/module/mes/as-i386.mes b/module/mes/as-i386.mes
deleted file mode 100644 (file)
index 1b8c8f4..0000000
+++ /dev/null
@@ -1,560 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; as-i386.mes defines i386 assembly
-
-;;; Code:
-
-(cond-expand
- (guile-2)
- (guile)
- (mes
-  (mes-use-module (mes as))))
-
-(define (i386:nop)
-  '(("nop")))
-
-(define (i386:function-preamble)
-  '(("push___%ebp")
-    ("mov____%esp,%ebp")))
-
-(define (i386:function-locals)
-  `(("sub____%esp,$i32" (#:immediate ,(+ (* 4 1025) (* 20 4)))))) ; sub %esp,xxx 4*1024 buf, 20 local vars
-
-(define (i386:push-label label)
-  `(("push___$i32" (#:address ,label)))) ; push  $0x<label>
-
-(define (i386:push-label-mem label)
-  `(("mov____0x32,%eax" (#:address ,label)) ; mov    0x804a000,%eax
-    ("push___%eax")))                       ; push  %eax
-
-
-;;; \f locals
-
-(define (i386:push-local n)
-  (or n (error "invalid value: push-local: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("push___0x8(%ebp)" (#:immediate1 ,n))
-           `("push___0x32(%ebp)" (#:immediate ,n))))))
-
-(define (i386:push-local-address n)
-  (or n (error "invalid value: push-local-address: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("lea____0x8(%ebp),%eax" (#:immediate1 ,n))
-           `("lea____0x32(%ebp),%eax" (#:immediate ,n)))
-      ("push___%eax"))))
-
-(define (i386:push-byte-local-de-ref n)
-  (or n (error "invalid value: push-byte-local-de-ref: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("mov____0x8(%ebp),%eax" (#:immediate1 ,n))
-           `("mov____0x32(%ebp),%eax" (#:immediate ,n)))
-      ("movzbl_(%eax),%eax")
-      ("push___%eax"))))
-
-(define (i386:push-word-local-de-ref n)
-  (or n (error "invalid value: push-word-local-de-ref: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("mov____0x8(%ebp),%eax" (#:immediate1 ,n))
-           `("mov____0x32(%ebp),%eax" (#:immediate ,n)))
-      ("movzwl_(%eax),%eax")
-      ("push___%eax"))))
-
-(define (i386:push-byte-local-de-de-ref n)
-  (or n (error "invalid value: push-byte-local-de-de-ref: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("mov____0x8(%ebp),%eax" (#:immediate1 ,n))
-           `("mov____0x32(%ebp),%eax" (#:immediate ,n)))
-      ("mov____(%eax),%eax")
-      ("movzbl_(%eax),%eax")
-      ("push___%eax"))))
-
-(define (i386:push-local-de-ref n)
-  (or n (error "invalid value: push-byte-local-de-ref: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("mov____0x8(%ebp),%eax" (#:immediate1 ,n))
-           `("mov____0x32(%ebp),%eax" (#:immediate ,n)))
-      ("mov____(%eax),%eax")
-      ("push___%eax"))))
-
-(define (i386:local-add n v)
-  (or n (error "invalid value: i386:local-add: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (and (< (abs n) #x80)
-                (< (abs v) #x80)) `("add____$i8,0x8(%ebp)" (#:immediate1 ,n) (#:immediate1 ,v))
-                `("add____$i32,0x32(%ebp)" (#:immediate ,n) (#:immediate ,v))))))
-
-(define (i386:accu->local n)
-  (or n (error "invalid value: accu->local: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("mov____%eax,0x8(%ebp)" (#:immediate1 ,n))
-           `("mov____%eax,0x32(%ebp)" (#:immediate ,n))))))
-
-(define (i386:accu->local+n id n)
-  (let ((n (+ (- 0 (* 4 id)) n)))
-    `(,(if (< (abs n) #x80) `("mov____%eax,0x8(%ebp)" (#:immediate1 ,n))
-           `("mov____%eax,0x32(%ebp)" (#:immediate ,n))))))
-
-(define (i386:accu*n->local i n)
-  (or n (error "invalid value: accu->local: " n))
-  (let ((o (- 0 (* 4 i))))
-    (let loop ((i 0))
-      (if (>= i n) '()  ;; FIXME: byte, word-sized
-          (let ((o (+ o i)))
-            (append
-             (if (< (abs o) #x80) `(("mov____0x8(%eax),%ebx" (#:immediate1 ,i))
-                                    ("mov____%ebx,0x8(%ebp)" (#:immediate1 ,o)))
-                 `(("mov____0x8(%eax),%ebx" (#:immediate1 ,i))
-                   ("mov____%ebx,0x32(%ebp)" (#:immediate ,o))))
-             (loop (+ i 4))))))))
-
-(define (i386:local->accu n)
-  (or n (error "invalid value: local->accu: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("mov____0x8(%ebp),%eax" (#:immediate1 ,n))
-           `("mov____0x32(%ebp),%eax" (#:immediate ,n))))))
-
-(define (i386:local-address->accu n)
-  (or n (error "invalid value: ladd: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("lea____0x8(%ebp),%eax" (#:immediate1 ,n))
-           `("lea____0x32(%ebp),%eax" (#:immediate ,n))))))
-
-(define (i386:local-ptr->accu n)
-  (or n (error "invalid value: local-ptr->accu: " n))
-  (let ((n (- 0 (* 4 n))))
-  `(("mov____%ebp,%eax")                ; mov    %ebp,%eax
-    ,(if (< (abs n) #x80) `("add____$i8,%eax" (#:immediate1 ,n))
-         `("add____$i32,%eax" (#:immediate ,n))))))
-
-(define (i386:byte-local->base n)
-  (or n (error "invalid value: byte-local->base: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("movzbl_0x8(%ebp),%edx" (#:immediate1 ,n))
-           `,@(("mov_0x32(%ebp),%edx" (#:immediate ,n))
-               ("movzbl_%dl,%edx"))))))
-
-(define (i386:local->base n)
-  (or n (error "invalid value: local->base: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("mov____0x8(%ebp),%edx" (#:immediate1 ,n))
-           `("mov____0x32(%ebp),%edx" (#:immediate ,n))))))
-
-(define (i386:local-address->base n) ;; DE-REF
-  (or n (error "invalid value: local-address->base: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("lea____0x8(%ebp),%edx" (#:immediate1 ,n))
-           `("lea____0x32(%ebp),%edx" (#:immediate ,n))))))
-
-(define (i386:local-ptr->base n)
-  (or n (error "invalid value: local-ptr->base: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(("mov____%ebp,%edx")                ; mov    %ebp,%edx
-      ,(if (< (abs n) #x80) `("add____$i8,%edx" (#:immediate1 ,n))
-           `("add____$i32,%edx" (#:immediate ,n))))))
-
-(define (i386:value->local n v)
-  (or n (error "invalid value: value->local: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(if (< (abs n) #x80) `("mov____$i32,0x8(%ebp)" (#:immediate1 ,n) (#:immediate ,v))
-           `("mov____$i32,0x32(%ebp)" (#:immediate ,n) (#:immediate ,v))))))
-
-(define (i386:local-test n v)
-  (or n (error "invalid value: local-test: " n))
-  (let ((n (- 0 (* 4 n))))
-    `(,(cond ((and (< (abs n) #x80)
-                   (< (abs v) #x80)) `("cmp____$i8,0x8(%ebp)" (#:immediate1 ,n) (#:immediate1 ,v)))
-             ((< (abs n) #x80) `("cmp____$i32,0x8(%ebp)" (#:immediate1 ,n) (#:immediate ,v)))
-             ((< (abs v) #x80) `("cmp____$i8,0x32(%ebp)" (#:immediate ,n) (#:immediate1 ,v)))
-             (else `("cmp____$i32,0x32(%ebp)" (#:immediate ,n) (#:immediate ,v)))))))
-
-(define (i386:pop-accu)
-  '(("pop____%eax")))                   ; pop %eax
-
-(define (i386:push-accu)
-  '(("push___%eax")))                   ; push %eax
-
-(define (i386:pop-base)
-  '(("pop____%edx")))                   ; pop %edx
-
-(define (i386:push-base)
-  '(("push___%edx")))                   ; push %edx
-
-(define (i386:ret)
-  '(("leave")                           ; leave
-    ("ret")))                           ; ret
-
-(define (i386:accu->base)
-  '(("mov____%eax,%edx")))              ; mov    %eax,%edx
-
-(define (i386:accu->base-mem)
-  '(("mov____%eax,(%edx)")))            ; mov    %eax,(%edx)
-
-(define (i386:byte-accu->base-mem)
-  '(("mov____%al,(%edx)")))             ; mov    %al,(%edx)
-
-(define (i386:word-accu->base-mem)
-  '(("mov____%ax,(%edx)")))             ; mov    %ax,(%edx)
-
-(define (i386:accu->base-mem+n n)
-  (or n (error "invalid value: accu->base-mem+n: " n))
-  `(,(if (< (abs n) #x80) `("mov____%eax,0x8(%edx)" (#:immediate1 ,n))
-         `("mov____%eax,0x32(%edx)" (#:immediate ,n)))))
-
-(define (i386:byte-accu->base-mem+n n)
-  (or n (error "invalid value: accu->base-mem+n: " n))
-  `(,(if (< (abs n) #x80) `("mov____%al,0x8(%edx)" (#:immediate1 ,n))
-         `("mov____%al,0x32(%edx)" (#:immediate ,n)))))
-
-(define (i386:word-accu->base-mem+n n)
-  (or n (error "invalid value: accu->base-mem+n: " n))
-  `(,(if (< (abs n) #x80) `("mov____%ax,0x8(%edx)" (#:immediate1 ,n))
-         `("mov____%ax,0x32(%edx)" (#:immediate ,n)))))
-
-(define (i386:accu->label label)
-  `(("mov____%eax,0x32" (#:address ,label)))) ; mov    %eax,0x<label>
-
-(define (i386:accu*n->label label n)
-  (append
-   '(("push___%edx"))
-   (let loop ((i 0))
-     (if (>= i n) '() ;; FIXME: byte, word-sized
-         (append
-          `(("mov____$i32,%edx" (#:address ,label))
-            ("mov____0x8(%eax),%ebx" (#:immediate1 ,i))
-            ("mov____%ebx,0x8(%edx)" (#:immediate1 ,i)))
-          (loop (+ i 4)))))
-   '(("pop____%edx"))))
-
-(define (i386:accu-shl n)
-  (or n (error "invalid value: accu:shl n: " n))
-  `(("shl____$i8,%eax" (#:immediate1 ,n)))) ; shl    $0x8,%eax
-
-(define (i386:accu<<base)
-  '(("xor____%ecx,%ecx")                ; xor    %ecx,%ecx
-    ("mov____%edx,%ecx")                ; mov    %edx,%ecx
-    ("shl____%cl,%eax")))               ; shl    %cl,%eax
-
-(define (i386:accu>>base)
-  '(("xor____%ecx,%ecx")                ; xor    %ecx,%ecx
-    ("mov____%edx,%ecx")                ; mov    %edx,%ecx
-    ("shr____%cl,%eax")))               ; shr    %cl,%eax
-
-(define (i386:accu-and-base)
-  '(("and____%edx,%eax")))
-
-(define (i386:accu-and v)
-  `(("and____$i32,%eax" (#:immediate ,v))))
-
-(define (i386:accu-and-base-mem)
-  '(("and____(%edx),%eax")))
-
-(define (i386:accu-or-base-mem)
-  '(("or_____(%edx),%eax")))
-
-(define (i386:accu-not)
-  '(("not____%eax")))                   ; not %eax
-
-(define (i386:accu-or-base)
-  '(("or_____%edx,%eax")))              ; or    %edx,%eax
-
-(define (i386:accu-xor-base)
-  '(("xor____%edx,%eax")))              ; xor    %edx,%eax
-
-(define (i386:accu+accu)
-  '(("add____%eax,%eax")))              ; add    %eax,%eax
-
-(define (i386:accu+base)
-  `(("add____%edx,%eax")))              ; add    %edx,%eax
-
-(define (i386:accu+value v)
-  `(,(if (< (abs v) #x80) `("add____$i8,%eax" (#:immediate1 ,v))
-         `("add____$i32,%eax" (#:immediate ,v)))))
-
-(define (i386:base+value v)
-  `(,(if (< (abs v) #x80) `("add____$i8,%edx" (#:immediate1 ,v))
-         `("add____$i32,%edx" (#:immediate ,v)))))
-
-(define (i386:accu-base)
-  `(("sub____%edx,%eax")))              ; sub    %edx,%eax
-
-(define (i386:accu*base)
-  `(("mul____%edx")))                   ; mul    %edx
-
-(define (i386:accu/base)
-  '(("mov____%edx,%ebx")                ; mov    %edx,%ebx
-    ("xor____%edx,%edx")                ; xor    %edx,%edx
-    ("idiv___%ebx")))                   ; div    %ebx
-
-(define (i386:accu%base)
-  '(("mov____%edx,%ebx")                ; mov    %edx,%ebx
-    ("xor____%edx,%edx")                ; xor    %edx,%edx
-    ("idiv___%ebx")                     ; div    %ebx
-    ("mov____%edx,%eax")))              ; mov    %edx,%eax
-
-(define (i386:base->accu)
-  '(("mov____%edx,%eax")))              ; mov    %edx,%eax
-
-(define (i386:label->accu label)
-  `(("mov____$i32,%eax" (#:address ,label)))) ; mov    $<n>,%eax
-
-(define (i386:label->base label)
-  `(("mov____$i32,%edx" (#:address ,label)))) ; mov   $<n>,%edx
-
-(define (i386:label-mem->accu label)
-  `(("mov____0x32,%eax" (#:address ,label)))) ; mov    0x<n>,%eax
-
-(define (i386:label-mem->base label)
-  `(("mov____0x32,%edx" (#:address ,label)))) ; mov    0x<n>,%edx
-
-(define (i386:label-mem-add label v)
-  `(,(if (< (abs v) #x80) `("add____$i8,0x32" (#:address ,label) (#:immediate1 ,v))
-         `("add____$i32,0x32" (#:address ,label) (#:immediate ,v)))))
-
-(define (i386:byte-base-mem->accu)
-  '(("add____%edx,%eax")                ; add    %edx,%eax
-    ("movzbl_(%eax),%eax")))            ; movzbl (%eax),%eax
-
-(define (i386:byte-mem->accu)
-  '(("movzbl_(%eax),%eax")))            ; movzbl (%eax),%eax
-
-(define (i386:word-mem->accu)
-  '(("movzwl_(%eax),%eax")))
-
-(define (i386:byte-mem->base)
-  '(("movzbl_(%edx),%edx")))            ; movzbl (%edx),%edx
-
-(define (i386:base-mem->accu)
-  '(("mov____(%edx),%eax")))
-
-(define (i386:mem->accu)
-  '(("mov____(%eax),%eax")))
-
-(define (i386:mem->base)
-  '(("mov____(%edx),%edx")))
-
-(define (i386:mem+n->accu n)
-  `(,(if (< (abs n) #x80) `("mov____0x8(%eax),%eax" (#:immediate1 ,n))
-         `("mov____0x32(%eax),%eax" (#:immediate ,n)))))
-
-(define (i386:byte-mem+n->accu n)
-  `(,(if (< (abs n) #x80) `("movzbl_0x8(%eax),%eax" (#:immediate1 ,n))
-         `("movzbl_0x32(%eax),%eax" (#:immediate ,n)))))
-
-(define (i386:word-mem+n->accu n)
-  `(,(if (< (abs n) #x80) `("movzwl_0x8(%eax),%eax" (#:immediate1 ,n))
-         `("movzwl_xb0x32(%eax),%eax" (#:immediate ,n)))))
-
-(define (i386:base-mem+n->accu v)
-  (or v (error "invalid value: base-mem+n->accu: " v))
-  `(("add___%edx,%eax")
-    ,(if (< (abs v) #x80) `("mov____0x8(%eax),%eax" (#:immediate1 ,v))
-         `("mov____0x32(%eax),%eax" (#:immediate ,v)))))
-
-(define (i386:value->accu v)
-  (or v (error "invalid value: i386:value->accu: " v))
-  `(("mov____$i32,%eax" (#:immediate ,v)))) ; mov    $<v>,%eax
-
-(define (i386:value->accu-mem v)
-  `(("mov____$i32,(%eax)" (#:immediate ,v)))) ; movl   $0x<v>,(%eax)
-
-(define (i386:value->accu-mem+n n v)
-  (or v (error "invalid value: i386:value->accu-mem+n: " v))
-  `(,(if (< (abs v) #x80) `("mov____$i32,0x8(%eax)" (#:immediate1 ,n) (#:immediate ,v))
-         `("mov____$i32,0x32(%eax)" (#:immediate ,n) (#:immediate ,v)))))
-
-(define (i386:base->accu-mem)
-  '(("mov____%edx,(%eax)")))            ; mov    %edx,(%eax)
-
-(define (i386:accu-mem->base-mem)
-  '(("mov____(%eax),%ecx")
-    ("mov____%ecx,(%edx)")))
-
-(define (i386:base-mem->accu-mem)
-  '(("mov____(%edx),%ecx")              ; mov    (%edx),%ecx
-    ("mov____%ecx,(%eax)")))            ; mov    %ecx,(%eax)
-
-(define (i386:byte-base->accu-mem)
-  '(("mov____%dl,(%eax)")))             ; mov    %dl,(%eax)
-
-(define (i386:byte-base->accu-mem+n n)
-  (or n (error "invalid value: byte-base->accu-mem+n: " n))
-  `(,(if (< (abs n) #x80) `("mov____%dl,0x8(%eax)" (#:immediate1 ,n))
-         `("mov____%dl,0x32(%eax)" (#:immediate ,n)))))
-
-(define (i386:value->base v)
-  (or v (error "invalid value: i386:value->base: " v))
-  `(("mov____$i32,%edx" (#:immediate ,v)))) ; mov    $<v>,%edx
-
-(define (i386:accu-mem-add v)
-  `(,(if (< (abs v) #x80) `("add____$i8,(%eax)" (#:immediate1 ,v))
-         `("add____$i32,(%eax)" (#:immediate ,v)))))
-
-(define (i386:value->label label v)
-  (or v (error "invalid value: value->label: " v))
-  `(("mov____$i32,0x32" (#:address ,label)
-     (#:immediate ,v))))
-
-(define (i386:call-label label n)
-  `((call32 (#:offset ,label))
-    ("add____$i8,%esp" (#:immediate1 ,(* n 4)))))
-
-(define (i386:call-accu n)
-  `(,@(i386:push-accu)
-    ,@(i386:pop-accu)
-    ("call___*%eax")                    ; call   *%eax
-    ("add____$i8,%esp" (#:immediate1  ,(* n 4))))) ; add    $00,%esp
-
-(define (i386:accu-zero?)
-  '(("test___%eax,%eax")))
-
-(define (i386:accu-negate)
-  '(("sete___%al")                      ; sete %al
-    ("movzbl_%al,%eax")))               ; movzbl %al,%eax
-
-(define (i386:xor-accu v)
-  (or v (error "invalid value: i386:xor-accu: n: " v))
-  `(("xor___$i32,%eax" (#:immediate ,v)))) ;xor    $0xff,%eax
-
-(define (i386:xor-zf)
-  '(("lahf")                               ; lahf
-    ("xor____$i8,%ah" (#:immediate1 #x40)) ; xor    $0x40,%ah
-    ("sahf")))                             ; sahf
-
-(define (i386:accu-cmp-value v)
-  `(,(if (< (abs v) #x80) `("cmp____$i8,%eax" (#:immediate1 ,v))
-         `("cmp____$i32,%eax" (#:immediate ,v)))))
-
-(define (i386:accu-test)
-  '(("test___%eax,%eax")))              ; test   %eax,%eax
-
-(define (i386:jump label)
-  `(("jmp32 " (#:offset ,label))))
-
-(define (i386:jump-z label)
-  `(("je32  " (#:offset ,label))))        ; jz . + <n>
-
-(define (i386:jump-byte-z label)
-  `(("test___%al,%al")                  ; test   %al,%al
-    ("je32  " (#:offset ,label))))      ; je <n>
-
-;; signed
-(define (i386:jump-g label)
-  `(("jg32  " (#:offset ,label))))
-
-(define (i386:jump-ge label)
-  `(("jge32 " (#:offset ,label))))
-
-(define (i386:jump-l label)
-  `(("jl32  " (#:offset ,label))))
-
-(define (i386:jump-le label)
-  `(("jle32 " (#:offset ,label))))
-
-(define (i386:g?->accu)
-  '(("setg___%al")
-    ("movzbl_%al,%eax")))
-
-(define (i386:ge?->accu)
-  '(("setge__%al")
-    ("movzbl_%al,%eax")))
-
-(define (i386:l?->accu)
-  '(("setl___%al")
-    ("movzbl_%al,%eax")))
-
-(define (i386:le?->accu)
-  '(("setle__%al")
-    ("movzbl_%al,%eax")))
-
-;; unsigned
-(define (i386:jump-a label)
-  `(("ja32  " (#:offset ,label))))
-
-(define (i386:jump-ae label)
-  `(("jae32 " (#:offset ,label))))
-
-(define (i386:jump-b label)
-  `(("jb32  " (#:offset ,label))))
-
-(define (i386:jump-be label)
-  `(("jbe32 " (#:offset ,label))))
-
-(define (i386:a?->accu)
-  '(("seta___%al")
-    ("movzbl_%al,%eax")))
-
-(define (i386:ae?->accu)
-  '(("setae__%al")
-    ("movzbl_%al,%eax")))
-
-(define (i386:b?->accu)
-  '(("setb___%al")
-    ("movzbl_%al,%eax")))
-
-(define (i386:be?->accu)
-  '(("setbe__%al")
-    ("movzbl_%al,%eax")))
-
-(define (i386:jump-nz label)
-  `(("jne32 " (#:offset ,label))))       ; jnz . + <n>
-
-(define (i386:byte-test-base)
-  '(("cmp____%al,%dl")))                ; cmp    %al,%dl
-
-(define (i386:test-base)
-  (("cmp____%edx,%eax")))               ; cmp    %edx,%eax
-
-(define (i386:byte-sub-base)
-  '(("sub____%dl,%al")))                ; sub    %dl,%al
-
-(define (i386:byte-base-sub)
-  `(("sub____%al,%dl")))                ; sub    %al,%dl
-
-(define (i386:sub-base)
-  `(("sub____%edx,%eax")))              ; sub    %edx,%eax
-
-(define (i386:base-sub)
-  `(("sub____%eax,%edx")))              ; sub    %eax,%edx
-
-(define (i386:nz->accu)
-  '(("setne__%al")                      ; setne   %al
-    ("movzbl_%al,%eax")))               ; movzbl %al,%eax
-
-(define (i386:z->accu)
-  '(("sete___%al")                      ; sete   %al
-    ("movzbl_%al,%eax")))               ; movzbl %al,%eax
-
-(define (i386:accu<->stack)
-  '(("xchg___%eax,(%esp)")))            ; xchg   %eax,(%esp)
-
-(define (i386:byte-accu)
-  '(("movzbl_%al,%eax")))
-
-(define (i386:signed-byte-accu)
-  '(("movsbl_%al,%eax")))
-
-(define (i386:word-accu)
-  '(("movzwl_%ax,%eax")))
-
-(define (i386:signed-word-accu)
-  '(("movswl_%ax,%eax")))
diff --git a/module/mes/as-i386.scm b/module/mes/as-i386.scm
deleted file mode 100644 (file)
index d38ee7e..0000000
+++ /dev/null
@@ -1,172 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; as-i386.scm defines i386 assembly
-
-;;; Code:
-
-(define-module (mes as-i386)
-  #:use-module (mes guile)
-  #:use-module (mes as)
-  #:export (
-            i386:accu%base
-            i386:accu*base
-            i386:accu*n->label
-            i386:accu*n->local
-            i386:accu+accu
-            i386:accu+base
-            i386:accu+value
-            i386:accu->base
-            i386:accu->base-mem
-            i386:byte-accu->base-mem
-            i386:word-accu->base-mem
-            i386:accu->base-mem+n
-            i386:byte-accu->base-mem+n
-            i386:word-accu->base-mem+n
-            i386:accu->label
-            i386:accu->local
-            i386:accu->local+n
-            i386:accu->local+n
-            i386:accu-and
-            i386:accu-and-base
-            i386:accu-and-base-mem
-            i386:accu-base
-            i386:accu-cmp-value
-            i386:accu-mem-add
-            i386:accu-mem->base-mem
-            i386:accu-negate
-            i386:accu-not
-            i386:accu-or-base
-            i386:accu-or-base-mem
-            i386:accu-shl
-            i386:accu-test
-            i386:accu-xor-base
-            i386:accu-zero?
-            i386:accu/base
-            i386:accu<->stack
-            i386:accu<<base
-            i386:accu>>base
-            i386:base+value
-            i386:base->accu
-            i386:base->accu-mem
-            i386:base->label
-            i386:base-mem->accu-mem
-            i386:base-mem+n->accu
-            i386:base-mem->accu
-            i386:base-sub
-            i386:byte-accu->base-mem
-            i386:word-accu->base-mem
-            i386:byte-base->accu-mem
-            i386:byte-base->accu-mem+n
-            i386:byte-base-mem->accu
-            i386:byte-base-sub
-            i386:byte-local->base
-            i386:byte-mem->accu
-            i386:word-mem->accu
-            i386:byte-mem->base
-            i386:byte-sub-base
-            i386:byte-test-base
-            i386:call-accu
-            i386:call-label
-            i386:formal
-            i386:function-locals
-            i386:function-preamble
-            i386:jump
-            i386:jump
-            i386:jump-a
-            i386:jump-ae
-            i386:jump-b
-            i386:jump-be
-            i386:jump-byte-z
-            i386:jump-g
-            i386:jump-ge
-            i386:jump-l
-            i386:jump-le
-            i386:jump-nz
-            i386:jump-z
-            i386:label->accu
-            i386:label->base
-            i386:label-mem->accu
-            i386:label-mem->base
-            i386:label-mem-add
-            i386:local->accu
-            i386:local->base
-            i386:local-add
-            i386:local-address->accu
-            i386:local-address->accu
-            i386:local-address->base
-            i386:local-ptr->accu
-            i386:local-ptr->base
-            i386:local-test
-            i386:mem+n->accu
-            i386:byte-mem+n->accu
-            i386:word-mem+n->accu
-            i386:mem->accu
-            i386:mem->base
-            i386:nop
-            i386:nz->accu
-            i386:pop-accu
-            i386:pop-base
-            i386:push-accu
-            i386:push-base
-            i386:push-byte-local-de-de-ref
-            i386:push-byte-local-de-ref
-            i386:push-word-local-de-ref
-            i386:push-label
-            i386:push-label-mem
-            i386:push-local
-            i386:push-local-address
-            i386:push-local-de-ref
-            i386:ret
-            i386:ret-local
-            i386:sub-base
-            i386:test-base
-            i386:value->accu
-            i386:value->accu-mem
-            i386:value->accu-mem+n
-            i386:value->base
-            i386:value->label
-            i386:value->local
-            i386:xor-accu
-            i386:xor-zf
-            i386:g?->accu
-            i386:ge?->accu
-            i386:l?->accu
-            i386:le?->accu
-            i386:a?->accu
-            i386:ae?->accu
-            i386:b?->accu
-            i386:be?->accu
-            i386:z->accu
-            i386:byte-accu
-            i386:signed-byte-accu
-            i386:word-accu
-            i386:signed-word-accu
-            ))
-
-(cond-expand
- (guile-2)
- (guile
-  (use-modules (ice-9 syncase)))
- (mes))
-
-(include-from-path "mes/as-i386.mes")
diff --git a/module/mes/as.mes b/module/mes/as.mes
deleted file mode 100644 (file)
index d6508a6..0000000
+++ /dev/null
@@ -1,53 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; compiler.mes produces an i386 binary from the C produced by
-;;; Nyacc c99.
-
-;;; Code:
-
-(cond-expand
- (guile)
- (guile-2)
- (mes
-  (mes-use-module (srfi srfi-1))
-  (mes-use-module (mes bytevectors))))
-
-(define (int->bv32 value)
-  (let ((bv (make-bytevector 4)))
-    (bytevector-u32-native-set! bv 0 value)
-    bv))
-
-(define (int->bv16 value)
-  (let ((bv (make-bytevector 2)))
-    (bytevector-u16-native-set! bv 0 value)
-    bv))
-
-(define (int->bv8 value)
-  (let ((bv (make-bytevector 1)))
-    (bytevector-u8-set! bv 0 value)
-    bv))
-
-(define (dec->hex o)
-  (cond ((number? o) (number->string o 16))
-        ((char? o) (number->string (char->integer o) 16))
-        (else (format #f "~s" o))))
diff --git a/module/mes/as.scm b/module/mes/as.scm
deleted file mode 100644 (file)
index c7cb83b..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(define-module (mes as)
-  #:use-module (srfi srfi-1)
-  #:use-module (mes guile)
-  #:use-module (mes bytevectors)
-  #:export (dec->hex
-            int->bv8
-            int->bv16
-            int->bv32))
-
-(cond-expand
- (guile-2)
- (guile
-  (use-modules (ice-9 syncase)))
- (mes))
-
-(include-from-path "mes/as.mes")
index 8c987c46c447b2ab81ab7f0ab3e6aac8d3ffd364..32296a7cd03b4aed9f3916f08ff190fe33bb1a25 100644 (file)
 
 (define-macro (load file)
   (list 'begin
-        (list 'if (list getenv "MES_DEBUG")
+        (list 'if (list 'and (list getenv "MES_DEBUG")
+                        (list not (list equal2? (list getenv "MES_DEBUG") "0"))
+                        (list not (list equal2? (list getenv "MES_DEBUG") "1")))
               (list 'begin
                     (list core:display-error ";;; read ")
                     (list core:display-error file)
                      "@VERSION@"))
 (define (effective-version) %version)
 
-(if (getenv "MES_DEBUG")
+(if (list 'and (list getenv "MES_DEBUG")
+          (list not (list equal2? (list getenv "MES_DEBUG") "0"))
+          (list not (list equal2? (list getenv "MES_DEBUG") "1")))
     (begin
       (core:display-error ";;; %moduledir=")
       (core:display-error %moduledir)
@@ -295,7 +299,7 @@ remaining arguments as the value of (command-line).
              (set! %argv files)
              (set-current-input-port port)))
           ((and (null? files) tty?)
-           
+
            (mes-use-module (mes repl))
            (set-current-input-port 0)
            (repl))
diff --git a/module/mes/bytevectors.mes b/module/mes/bytevectors.mes
deleted file mode 100644 (file)
index 2a19676..0000000
+++ /dev/null
@@ -1,55 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; bytevectors.mes 
-
-;;; Code:
-
-;; rnrs compatibility
-(define (bytevector-u32-native-set! bv index value)
-  (when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value))
-  (let ((x (list
-            (modulo value #x100)
-            (modulo (ash value -8) #x100)
-            (modulo (ash value -16) #x100)
-            (modulo (ash value -24) #x100))))
-    (set-car! bv (car x))
-    (set-cdr! bv (cdr x))
-    x))
-
-(define (bytevector-u16-native-set! bv index value)
-  (when (not (= 0 index)) (error "bytevector-u16-native-set! index not zero: " index " value: " value))
-  (let ((x (list
-            (modulo value #x100)
-            (modulo (ash value -8) #x100))))
-    (set-car! bv (car x))
-    (set-cdr! bv (cdr x))
-    x))
-
-(define (bytevector-u8-set! bv index value)
-  (when (not (= 0 index)) (error "bytevector-u8-set! index not zero: " index " value: " value))
-  (let ((x (modulo value #x100)))
-    (set-car! bv x)
-    x))
-
-(define (make-bytevector length)
-  (make-list length 0))
diff --git a/module/mes/bytevectors.scm b/module/mes/bytevectors.scm
deleted file mode 100644 (file)
index c241553..0000000
+++ /dev/null
@@ -1,38 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(define-module (mes bytevectors)
-  #:use-module (mes guile)
-  #:export (bytevector-u32-native-set!
-            bytevector-u16-native-set!
-            bytevector-u8-set!
-            make-bytevector))
-
-(cond-expand
- (guile-2)
- (guile
-  (use-modules (ice-9 syncase)))
- (mes))
-
-(include-from-path "mes/bytevectors.mes")
diff --git a/module/mes/elf.mes b/module/mes/elf.mes
deleted file mode 100644 (file)
index 481abf8..0000000
+++ /dev/null
@@ -1,32 +0,0 @@
-<;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; elf.mes - produce a i386 elf executable.
-
-;;; Code:
-
-(cond-expand
- (guile)
- (mes))
-
-(define (M1->elf objects)
-  (error "->ELF support dropped, use M1"))
diff --git a/module/mes/elf.scm b/module/mes/elf.scm
deleted file mode 100644 (file)
index 22da8fb..0000000
+++ /dev/null
@@ -1,35 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of Mes.
-;;;
-;;; 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.
-;;;
-;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(define-module (mes elf)
-  #:use-module (mes guile)
-  #:export (M1->elf))
-
-(cond-expand
- (guile-2)
- (guile
-  (use-modules (ice-9 syncase)))
- (mes))
-
-(include-from-path "mes/elf.mes")
index c13e89307c334dd2f6b3326a74752b45616e6796..c50925a81ed45cbea9b1b325964f5edad767012b 100644 (file)
 
 ;;; Code:
 
+(mes-use-module (srfi srfi-13))
+
 (define-macro (cond-expand-provide . rest) #t)
 
 (define-macro (include-from-path file)
   (let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:))))
-    (if (getenv "MES_DEBUG")
-        ;;(format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path)
-        (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
+    (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
+           (core:display-error (string-append "include-from-path: " file "\n")))
+          ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number)))
+          (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
     (if (null? path) (error "include-from-path: not found: " file)
         (let ((file (string-append (car path) "/" file)))
           (if (access? file R_OK) `(load ,file)
@@ -37,7 +40,6 @@
 (mes-use-module (mes catch))
 (mes-use-module (mes posix))
 (mes-use-module (srfi srfi-16))
-(mes-use-module (srfi srfi-26))
 (mes-use-module (mes display))
 
 (if #t ;;(not (defined? 'read-string))
@@ -46,7 +48,7 @@
         (if (eq? c #\*eof*) '()
             (cons c (read-string (read-char)))))
       (let ((string (list->string (read-string (read-char)))))
-        (if (and=> (getenv "MES_DEBUG") (compose (cut > <> 3) string->number))
+        (if (and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 3)) string->number))
             (core:display-error (string-append "drained: `" string "'\n")))
         string)))
 
         (with-output-to-string
           (lambda () (simple-format lst rest))))))
 (define format simple-format)
-
diff --git a/module/mes/mescc.mes b/module/mes/mescc.mes
new file mode 100644 (file)
index 0000000..cb8ff2a
--- /dev/null
@@ -0,0 +1,25 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(include-from-path "mes/mescc.scm")
diff --git a/module/mes/misc.mes b/module/mes/misc.mes
new file mode 100644 (file)
index 0000000..6988ce8
--- /dev/null
@@ -0,0 +1,21 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(include-from-path "mes/misc.scm")
diff --git a/module/mes/misc.scm b/module/mes/misc.scm
new file mode 100644 (file)
index 0000000..35c964e
--- /dev/null
@@ -0,0 +1,65 @@
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mes misc)
+  #:use-module (srfi srfi-1)
+  #:export (%scheme
+            disjoin
+            guile?
+            mes?
+            pke
+            stderr
+            string-substitute))
+
+(cond-expand
+ (mes
+  (define %scheme "mes"))
+ (guile
+  (define %scheme "guile")))
+
+(define guile? (equal? %scheme "guile"))
+(define mes? (equal? %scheme "mes"))
+
+(define (logf port string . rest)
+  (apply format (cons* port string rest))
+  (force-output port)
+  #t)
+
+(define (stderr string . rest)
+  (apply logf (cons* (current-error-port) string rest)))
+
+(define (pke . stuff)
+  (newline (current-error-port))
+  (display ";;; " (current-error-port))
+  (write stuff (current-error-port))
+  (newline (current-error-port))
+  (car (last-pair stuff)))
+
+(define (disjoin . predicates)
+  (lambda (. arguments)
+    (any (lambda (o) (apply o arguments)) predicates)))
+
+(define (string-substitute string find replace)
+  (let ((index (string-contains string find)))
+    (if (not index) string
+        (string-append
+         (string-take string index)
+         replace
+         (string-substitute
+          (string-drop string (+ index (string-length find)))
+          find replace)))))
index 5c039a60e3641388ebab995cb84234739df75074..1cacf70d3ec18943dbc768285baaa8d8c7c25550 100644 (file)
@@ -22,6 +22,8 @@
 
 ;;; Code:
 
+(mes-use-module (srfi srfi-13))
+
 (define R_OK 0)
 (define S_IRWXU #o700)
 
diff --git a/module/mescc/M1.mes b/module/mescc/M1.mes
new file mode 100644 (file)
index 0000000..057c5eb
--- /dev/null
@@ -0,0 +1,28 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(mes-use-module (srfi srfi-1))
+(mes-use-module (srfi srfi-26))
+(mes-use-module (mes misc))
+(mes-use-module (mes optargs))
+(mes-use-module (mes pmatch))
+(mes-use-module (mescc as))
+(mes-use-module (mescc info))
+(include-from-path "mescc/M1.scm")
diff --git a/module/mescc/M1.scm b/module/mescc/M1.scm
new file mode 100644 (file)
index 0000000..1294167
--- /dev/null
@@ -0,0 +1,192 @@
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; M1.scm produces stage0' M1 assembly format
+
+;;; Code:
+
+(define-module (mescc M1)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (system base pmatch)
+  #:use-module (mes misc)
+  #:use-module (mes guile)
+
+  #:use-module (mescc as)
+  #:use-module (mescc info)
+  #:export (info->M1
+            infos->M1
+            M1:merge-infos))
+
+(define (infos->M1 file-name infos)
+  (let ((info (fold M1:merge-infos (make <info>) infos)))
+    (info->M1 file-name info)))
+
+(define (M1:merge-infos o info)
+  (clone info
+         #:functions (alist-add (.functions info) (.functions o))
+         #:globals (alist-add (.globals info) (.globals o))))
+
+(define (alist-add a b)
+  (let* ((b-keys (map car b))
+         (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
+         (a-keys (map car a)))
+    (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
+
+(define (hex2:address o)
+  (string-append "&" o))
+
+(define (hex2:offset o)
+  (string-append "%" o))
+
+(define (hex2:offset1 o)
+  (string-append "!" o))
+
+(define hex? #t)
+
+(define (hex2:immediate o)
+  (if hex? (string-append "%0x" (dec->hex o))
+      (string-append "%" (number->string o))))
+
+(define (hex2:immediate1 o)
+  (if hex? (string-append "!0x" (dec->hex o))
+      (string-append "!" (number->string o))))
+
+(define* (display-join o #:optional (sep ""))
+  (let loop ((o o))
+    (when (pair? o)
+      (display (car o))
+      (if (pair? (cdr o))
+          (display sep))
+      (loop (cdr o)))))
+
+(define (info->M1 file-name o)
+  (let* ((functions (.functions o))
+         (function-names (map car functions))
+         (globals (.globals o))
+         (global-names (map car globals))
+         (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
+    (define (string->label o)
+      (let ((index (list-index (lambda (s) (equal? s o)) strings)))
+        (if index
+            (string-append "_string_" file-name "_" (number->string index))
+            (error "no such string:" o))))
+    (define (text->M1 o)
+      (cond
+       ((char? o) (text->M1 (char->integer o)))
+       ((string? o) o)
+       ((symbol? o) (symbol->string o))
+       ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
+                      (if hex? (string-append "!0x"
+                                              (if (and (>= o 0) (< o 16)) "0" "")
+                                              (number->string o 16))
+                          (string-append "!" (number->string o)))))
+       ((and (pair? o) (keyword? (car o)))
+        (pmatch o
+          ;; FIXME
+          ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
+          ((#:address (#:address ,address)) (guard (string? address))
+           (hex2:address address))
+          ((#:address (#:address ,global)) (guard (global? global))
+           (hex2:address (global->string global)))
+          ((#:address ,function) (guard (function? function))
+           (hex2:address (function->string function)))
+          ((#:address ,number) (guard (number? number))
+           (string-join (map text->M1 (int->bv32 number))))
+          ((#:string ,string)
+           (hex2:address (string->label o)))
+          ((#:address ,address) (guard (string? address)) (hex2:address address))
+          ((#:address ,global) (guard (global? global))
+           (hex2:address (global->string global)))
+          ((#:offset ,offset) (hex2:offset offset))
+          ((#:offset1 ,offset1) (hex2:offset1 offset1))
+          ((#:immediate ,immediate) (hex2:immediate immediate))
+          ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
+          (_ (error "text->M1 no match o" o))))
+       ((pair? o) (string-join (map text->M1 o)))))
+    (define (write-function o)
+      (let ((name (car o))
+            (text (function:text (cdr o))))
+        (define (line->M1 o)
+          (cond ((eq? (car o) #:label)
+                 (display (string-append ":" (cadr o))))
+                ((eq? (car o) #:comment)
+                 (display "\t\t\t\t\t# ")
+                 (display (text->M1 (cadr o))))
+                ((or (string? (car o)) (symbol? (car o)))
+                 (display "\t" )
+                 (display-join (map text->M1 o) " "))
+                (else (error "line->M1 invalid line:" o)))
+          (newline))
+        (display (string-append "    :" name "\n") (current-error-port))
+        (display (string-append "\n\n:" name "\n"))
+        (for-each line->M1 (apply append text))))
+    (define (write-global o)
+      (define (labelize o)
+        (if (not (string? o)) o
+            (let* ((label o)
+                   (function? (member label function-names))
+                   (string-label (string->label label))
+                   (string? (not (equal? string-label "_string_#f"))))
+              (cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
+                    ((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
+                    (else (string-append "&" label))))))
+      (define (display-align size)
+        (let ((alignment (- 4 (modulo size 4))))
+          (when (> 4 alignment 0)
+            (display " ")
+            (display-join (map text->M1 (map (const 0) (iota alignment))) " "))))
+      (let* ((label (cond
+                     ((and (pair? (car o)) (eq? (caar o) #:string))
+                      (string->label (car o)))
+                     ((global? (cdr o)) (global->string (cdr o)))
+                     (else (car o))))
+             (string? (string-prefix? "_string" label))
+             (foo (if (not (eq? (car (string->list label)) #\_))
+                      (display (string-append "    :" label "\n") (current-error-port))))
+             (data ((compose global:value cdr) o))
+             (data (filter-map labelize data))
+             (len (length data))
+             (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
+             (string-data (and string? (list-head data (1- (length data))))))
+        (display (string-append "\n:" label "\n"))
+        (if (and string-data
+                 (< len string-max)
+                 (char? (car data))
+                 (eq? (last data) #\nul)
+                 (not (find (cut memq <> '(#\")) string-data))
+                 (not (any (lambda (ch)
+                             (or (and (not (memq ch '(#\tab #\newline)))
+                                      (< (char->integer ch) #x20))
+                                 (>= (char->integer ch) #x80))) string-data)))
+            (let ((text string-data))
+              (display (string-append "\"" (list->string string-data) "\""))
+              (display-align (1+ (length string-data))))
+            (let ((text (map text->M1 data)))
+              (display-join  text " ")
+              (display-align (length text))))
+        (newline)))
+    (display "M1: functions\n" (current-error-port))
+    (for-each write-function (filter cdr functions))
+    (when (assoc-ref functions "main")
+      (display "\n\n:ELF_data\n") ;; FIXME
+      (display "\n\n:HEX2_data\n"))
+    (display "M1: globals\n" (current-error-port))
+    (for-each write-global globals)))
diff --git a/module/mescc/as.mes b/module/mescc/as.mes
new file mode 100644 (file)
index 0000000..92d88e0
--- /dev/null
@@ -0,0 +1,23 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(mes-use-module (srfi srfi-1))
+(mes-use-module (mescc bytevectors))
+(include-from-path "mescc/as.scm")
diff --git a/module/mescc/as.scm b/module/mescc/as.scm
new file mode 100644 (file)
index 0000000..b4a85cd
--- /dev/null
@@ -0,0 +1,46 @@
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mescc as)
+  #:use-module (srfi srfi-1)
+  #:use-module (mes guile)
+  #:use-module (mescc bytevectors)
+  #:export (dec->hex
+            int->bv8
+            int->bv16
+            int->bv32))
+
+(define (int->bv32 value)
+  (let ((bv (make-bytevector 4)))
+    (bytevector-u32-native-set! bv 0 value)
+    bv))
+
+(define (int->bv16 value)
+  (let ((bv (make-bytevector 2)))
+    (bytevector-u16-native-set! bv 0 value)
+    bv))
+
+(define (int->bv8 value)
+  (let ((bv (make-bytevector 1)))
+    (bytevector-u8-set! bv 0 value)
+    bv))
+
+(define (dec->hex o)
+  (cond ((number? o) (number->string o 16))
+        ((char? o) (number->string (char->integer o) 16))
+        (else (format #f "~s" o))))
diff --git a/module/mescc/bytevectors.mes b/module/mescc/bytevectors.mes
new file mode 100644 (file)
index 0000000..da91c72
--- /dev/null
@@ -0,0 +1,21 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(include-from-path "mescc/bytevectors.scm")
diff --git a/module/mescc/bytevectors.scm b/module/mescc/bytevectors.scm
new file mode 100644 (file)
index 0000000..b1cf14a
--- /dev/null
@@ -0,0 +1,58 @@
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(define-module (mescc bytevectors)
+  #:use-module (mes guile)
+  #:export (bytevector-u32-native-set!
+            bytevector-u16-native-set!
+            bytevector-u8-set!
+            make-bytevector))
+
+;; rnrs compatibility
+(define (bytevector-u32-native-set! bv index value)
+  (when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value))
+  (let ((x (list
+            (modulo value #x100)
+            (modulo (ash value -8) #x100)
+            (modulo (ash value -16) #x100)
+            (modulo (ash value -24) #x100))))
+    (set-car! bv (car x))
+    (set-cdr! bv (cdr x))
+    x))
+
+(define (bytevector-u16-native-set! bv index value)
+  (when (not (= 0 index)) (error "bytevector-u16-native-set! index not zero: " index " value: " value))
+  (let ((x (list
+            (modulo value #x100)
+            (modulo (ash value -8) #x100))))
+    (set-car! bv (car x))
+    (set-cdr! bv (cdr x))
+    x))
+
+(define (bytevector-u8-set! bv index value)
+  (when (not (= 0 index)) (error "bytevector-u8-set! index not zero: " index " value: " value))
+  (let ((x (modulo value #x100)))
+    (set-car! bv x)
+    x))
+
+(define (make-bytevector length)
+  (make-list length 0))
diff --git a/module/mescc/compile.mes b/module/mescc/compile.mes
new file mode 100644 (file)
index 0000000..702363c
--- /dev/null
@@ -0,0 +1,33 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(mes-use-module (srfi srfi-1))
+(mes-use-module (srfi srfi-13))
+(mes-use-module (srfi srfi-26))
+(mes-use-module (mes pmatch))
+(mes-use-module (mes optargs))
+(mes-use-module (mes misc))
+(mes-use-module (nyacc lang c99 pprint))
+
+(mes-use-module (mescc as))
+(mes-use-module (mescc i386 as))
+(mes-use-module (mescc info))
+(mes-use-module (mescc M1))
+(include-from-path "mescc/compile.scm")
diff --git a/module/mescc/compile.scm b/module/mescc/compile.scm
new file mode 100644 (file)
index 0000000..b2e04a6
--- /dev/null
@@ -0,0 +1,2429 @@
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; 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.
+;;;
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(define-module (mescc compile)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-26)
+  #:use-module (system base pmatch)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (nyacc lang c99 pprint)
+
+  #:use-module (mes guile)
+  #:use-module (mes misc)
+
+  #:use-module (mescc preprocess)
+  #:use-module (mescc info)
+  #:use-module (mescc as)
+  #:use-module (mescc i386 as)
+  #:use-module (mescc M1)
+  #:export (c99-ast->info
+            c99-input->info
+            c99-input->object))
+
+(define mes? (pair? (current-module)))
+
+(define* (c99-input->info #:key (prefix "") (defines '()) (includes '()))
+  (let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes)))
+    (c99-ast->info ast)))
+
+(define* (c99-ast->info o)
+  (stderr "compiling: input\n")
+  (let ((info (ast->info o (make <info> #:types i386:type-alist))))
+    (clean-info info)))
+
+(define (clean-info o)
+  (make <info>
+    #:functions (filter (compose pair? function:text cdr) (.functions o))
+    #:globals (.globals o)))
+
+(define %int-size 4)
+(define %pointer-size %int-size)
+
+(define (ident->constant name value)
+  (cons name value))
+
+(define (enum->type-entry name fields)
+  (cons `(tag ,name) (make-type 'enum 4 fields)))
+
+(define (struct->type-entry name fields)
+  (let ((size (apply + (map (compose ->size cdr) fields))))
+    (cons `(tag ,name) (make-type 'struct size fields))))
+
+(define (union->type-entry name fields)
+  (let ((size (apply max (map (compose ->size cdr) fields))))
+    (cons `(tag ,name) (make-type 'union size fields))))
+
+(define i386:type-alist
+  `(("char" . ,(make-type 'signed 1 #f))
+    ("short" . ,(make-type 'signed 2 #f))
+    ("int" . ,(make-type 'signed 4 #f))
+    ("long" . ,(make-type 'signed 4 #f))
+    ("default" . ,(make-type 'signed 4 #f))
+    ;;("long long" . ,(make-type 'signed 8 #f))
+    ;;("long long int" . ,(make-type 'signed 8 #f))
+
+    ("long long" . ,(make-type 'signed 4 #f))  ;; FIXME
+    ("long long int" . ,(make-type 'signed 4 #f))
+
+    ("void" . ,(make-type 'void 1 #f))
+    ;; FIXME sign
+    ("unsigned char" . ,(make-type 'unsigned 1 #f))
+    ("unsigned short" . ,(make-type 'unsigned 2 #f))
+    ("unsigned short int" . ,(make-type 'unsigned 2 #f))
+    ("unsigned" . ,(make-type 'unsigned 4 #f))
+    ("unsigned int" . ,(make-type 'unsigned 4 #f))
+    ("unsigned long" . ,(make-type 'unsigned 4 #f))
+
+    ;; ("unsigned long long" . ,(make-type 'builtin 8 #f))
+    ;; ("unsigned long long int" . ,(make-type 'builtin 8 #f))
+    ("unsigned long long" . ,(make-type 'unsigned 4 #f)) ;; FIXME
+    ("unsigned long long int" . ,(make-type 'unsigned 4 #f))
+
+    ("float" . ,(make-type 'float 4 #f))
+    ("double" . ,(make-type 'float 8 #f))
+    ("long double" . ,(make-type 'float 16 #f))))
+
+(define (signed? o)
+  (eq? ((compose type:type ->type) o) 'signed))
+
+(define (unsigned? o)
+  (eq? ((compose type:type ->type) o) 'unsigned))
+
+(define (->size o)
+  (cond ((and (type? o) (eq? (type:type o) 'union))
+         (apply max (map (compose ->size cdr) (struct->fields o))))
+        ((type? o) (type:size o))
+        ((pointer? o) %pointer-size)
+        ((c-array? o) (* (c-array:count o) ((compose ->size c-array:type) o)))
+        ((local? o) ((compose ->size local:type) o))
+        ((global? o) ((compose ->size global:type) o))
+        ((bit-field? o) ((compose ->size bit-field:type) o))
+        ((and (pair? o) (pair? (car o)) (bit-field? (cdar o))) ((compose ->size cdar) o))
+        ;; FIXME
+        ;; (#t
+        ;;  (stderr "o=~s\n" o)
+        ;;  (format (current-error-port) "->size: not a <type>: ~s\n" o)
+        ;;  4)
+        (else (error "->size>: not a <type>:" o))))
+
+(define (ast->type o info)
+  (define (type-helper o info)
+    (if (getenv "MESC_DEBUG")
+        (stderr "type-helper: ~s\n" o))
+    (pmatch o
+      (,t (guard (type? t)) t)
+      (,p (guard (pointer? p)) p)
+      (,a (guard (c-array? a)) a)
+      (,b (guard (bit-field? b)) b)
+
+      ((char ,value) (get-type "char" info))
+      ((enum-ref . _) (get-type "default" info))
+      ((fixed ,value) (get-type "default" info))
+      ((float ,float) (get-type "float" info))
+      ((void) (get-type "void" info))
+
+      ((ident ,name) (ident->type info name))
+      ((tag ,name) (or (get-type o info)
+                       o))
+
+      (,name (guard (string? name))
+             (let ((type (get-type name info)))
+               (ast->type type info)))
+
+      ((type-name (decl-spec-list ,type) (abs-declr (pointer . ,pointer)))
+       (let ((rank (pointer->rank `(pointer ,@pointer)))
+             (type (ast->type type info)))
+         (rank+= type rank)))
+
+      ((type-name ,type) (ast->type type info))
+      ((type-spec ,type) (ast->type type info))
+
+      ((sizeof-expr ,expr) (ast->type expr info))
+      ((sizeof-type ,type) (ast->type type info))
+
+      ((string ,string) (make-c-array (get-type "char" info) (1+ (string-length string))))
+
+      ((decl-spec-list (type-spec ,type)) (ast->type type info))
+
+      ((fctn-call (p-expr (ident ,name)) . _)
+       (or (and=> (assoc-ref (.functions info) name) function:type)
+           (get-type "default" info)))
+
+      ((fctn-call (de-ref (p-expr (ident ,name))) . _)
+       (or (and=> (assoc-ref (.functions info) name) function:type)
+           (get-type "default" info)))
+
+      ((fixed-type ,type) (ast->type type info))
+      ((float-type ,type) (ast->type type info))
+      ((type-spec ,type) (ast->type type info))
+      ((typename ,type) (ast->type type info))
+
+      ((array-ref ,index ,array) (rank-- (ast->type array info)))
+
+      ((de-ref ,expr) (rank-- (ast->type expr info)))
+      ((ref-to ,expr) (rank++ (ast->type expr info)))
+
+      ((p-expr ,expr) (ast->type expr info))
+      ((pre-inc ,expr) (ast->type expr info))
+      ((post-inc ,expr) (ast->type expr info))
+
+      ((struct-ref (ident ,type))
+       (or (get-type type info)
+           (let ((struct (if (pair? type) type `(tag ,type))))
+             (ast->type struct info))))
+      ((union-ref (ident ,type))
+       (or (get-type type info)
+           (let ((struct (if (pair? type) type `(tag ,type))))
+             (ast->type struct info))))
+
+      ((struct-def (ident ,name) . _)
+       (ast->type `(tag ,name) info))
+      ((union-def (ident ,name) . _)
+       (ast->type `(tag ,name) info))
+      ((struct-def (field-list . ,fields))
+       (let ((fields (append-map (struct-field info) fields)))
+         (make-type 'struct (apply + (map field:size fields)) fields)))
+      ((union-def (field-list . ,fields))
+       (let ((fields (append-map (struct-field info) fields)))
+         (make-type 'union (apply + (map field:size fields)) fields)))
+      ((enum-def (enum-def-list . ,fields))
+       (get-type "default" info))
+
+      ((d-sel (ident ,field) ,struct)
+       (let ((type0 (ast->type struct info)))
+         (ast->type (field-type info type0 field) info)))
+
+      ((i-sel (ident ,field) ,struct)
+       (let ((type0 (ast->type (rank-- (ast->type struct info)) info)))
+         (ast->type (field-type info type0 field) info)))
+
+      ;; arithmetic
+      ((pre-inc ,a) (ast->type a info))
+      ((pre-dec ,a) (ast->type a info))
+      ((post-inc ,a) (ast->type a info))
+      ((post-dec ,a) (ast->type a info))
+      ((add ,a ,b) (ast->type a info))
+      ((sub ,a ,b) (ast->type a info))
+      ((bitwise-and ,a ,b) (ast->type a info))
+      ((bitwise-not ,a) (ast->type a info))
+      ((bitwise-or ,a ,b) (ast->type a info))
+      ((bitwise-xor ,a ,b) (ast->type a info))
+      ((lshift ,a ,b) (ast->type a info))
+      ((rshift ,a ,b) (ast->type a info))
+      ((div ,a ,b) (ast->type a info))
+      ((mod ,a ,b) (ast->type a info))
+      ((mul ,a ,b) (ast->type a info))
+      ((not ,a) (ast->type a info))
+      ((neg ,a) (ast->type a info))
+      ((eq ,a ,b) (ast->type a info))
+      ((ge ,a ,b) (ast->type a info))
+      ((gt ,a ,b) (ast->type a info))
+      ((ne ,a ,b) (ast->type a info))
+      ((le ,a ,b) (ast->type a info))
+      ((lt ,a ,b) (ast->type a info))
+
+      ;; logical
+      ((or ,a ,b) (ast->type a info))
+      ((and ,a ,b) (ast->type a info))
+
+      ((cast (type-name ,type) ,expr) (ast->type type info))
+
+      ((cast (type-name ,type (abs-declr ,pointer)) ,expr)
+       (let ((rank (pointer->rank pointer)))
+         (rank+= (ast->type type info) rank)))
+
+      ((decl-spec-list (type-spec ,type)) (ast->type type info))
+
+      ;;  ;; `typedef int size; void foo (unsigned size u)
+      ((decl-spec-list (type-spec ,type) (type-spec ,type2))
+       (ast->type type info))
+
+      ((assn-expr ,a ,op ,b) (ast->type a info))
+
+      ((cond-expr _ ,a ,b) (ast->type a info))
+
+      (_ (get-type o info))))
+
+  (let ((type (type-helper o info)))
+    (cond ((or (type? type)
+               (pointer? type) type
+               (c-array? type)) type)
+          ((and (equal? type o) (pair? type) (eq? (car type) 'tag)) o)
+          ((equal? type o)
+           (error "ast->type: not supported: " o))
+          (else (ast->type type info)))))
+
+(define (ast->basic-type o info)
+  (let ((type (->type (ast->type o info))))
+    (cond ((type? type) type)
+          ((equal? type o) o)
+          (else (ast->type type info)))))
+
+(define (get-type o info)
+  (let ((t (assoc-ref (.types info) o)))
+    (pmatch t
+      ((typedef ,next) (or (get-type next info) o))
+      (_ t))))
+
+
+(define (ast-type->size info o)
+  (let ((type (->type (ast->type o info))))
+    (cond ((type? type) (type:size type))
+          (else (stderr "ast-type->size barf: ~s => ~s\n" o type)
+                4))))
+
+(define (field:name o)
+  (pmatch o
+    ((struct (,name ,type ,size ,pointer) . ,rest) name)
+    ((union (,name ,type ,size ,pointer) . ,rest) name)
+    ((,name . ,type) name)
+    (_ (error "field:name not supported:" o))))
+
+(define (field:pointer o)
+  (pmatch o
+    ((struct (,name ,type ,size ,pointer) . ,rest) pointer)
+    ((union (,name ,type ,size ,pointer) . ,rest) pointer)
+    ((,name . ,type) (->rank type))
+    (_ (error "field:pointer not supported:" o))))
+
+(define (field:size o)
+  (pmatch o
+    ((struct . ,type) (apply + (map field:size (struct->fields type))))
+    ((union . ,type) (apply max (map field:size (struct->fields type))))
+    ((,name . ,type) (->size type))
+    (_ (error (format #f "field:size: ~s\n" o)))))
+
+(define (field-field info struct field)
+  (let ((fields (type:description struct)))
+    (let loop ((fields fields))
+      (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
+          (let ((f (car fields)))
+            (cond ((equal? (car f) field) f)
+                  ((and (memq (car f) '(struct union)) (type? (cdr f))
+                        (find (lambda (x) (equal? (car x) field)) (struct->fields (cdr f)))))
+                  ((eq? (car f) 'bits) (assoc field (cdr f)))
+                  (else (loop (cdr fields)))))))))
+
+(define (field-offset info struct field)
+  (if (eq? (type:type struct) 'union) 0
+      (let ((fields (type:description struct)))
+        (let loop ((fields fields) (offset 0))
+          (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
+              (let ((f (car fields)))
+                (cond ((equal? (car f) field) offset)
+                      ((and (eq? (car f) 'struct) (type? (cdr f)))
+                       (let ((fields (type:description (cdr f))))
+                         (find (lambda (x) (equal? (car x) field)) fields)
+                         (apply + (cons offset
+                                        (map field:size
+                                             (member field (reverse fields)
+                                                     (lambda (a b)
+                                                       (equal? a (car b) field))))))))
+                      ((and (eq? (car f) 'union) (type? (cdr f))
+                            (let ((fields (struct->fields (cdr f))))
+                              (and (find (lambda (x) (equal? (car x) field)) fields)
+                                   offset))))
+                      ((and (eq? (car f) 'bits) (assoc-ref (cdr f) field)) offset)
+                      (else (loop (cdr fields) (+ offset (field:size f)))))))))))
+
+(define (field-pointer info struct field)
+  (let ((field (field-field info struct field)))
+    (field:pointer field)))
+
+(define (field-size info struct field)
+  (if (eq? (type:type struct) 'union) 0
+      (let ((field (field-field info struct field)))
+        (field:size field))))
+
+(define (field-size info struct field)
+  (let ((field (field-field info struct field)))
+    (field:size field)))
+
+(define (field-type info struct field)
+  (let ((field (field-field info struct field)))
+    (ast->type (cdr field) info)))
+
+(define (struct->fields o)
+  (pmatch o
+    (_ (guard (and (type? o) (eq? (type:type o) 'struct)))
+       (append-map struct->fields (type:description o)))
+    (_ (guard (and (type? o) (eq? (type:type o) 'union)))
+       (append-map struct->fields (type:description o)))
+    ((struct . ,type) (list (car (type:description type))))
+    ((union . ,type) (list (car (type:description type))))
+    ((bits . ,bits) bits)
+    (_ (list o))))
+
+(define (struct->init-fields o)
+  (pmatch o
+    (_ (guard (and (type? o) (eq? (type:type o) 'struct)))
+       (append-map struct->init-fields (type:description o)))
+    (_ (guard (and (type? o) (eq? (type:type o) 'union)))
+       (append-map struct->init-fields (type:description o)))
+    ((struct . ,type) (struct->init-fields type))
+    ((union . ,type) (list (car (type:description type))))
+    (_ (list o))))
+
+(define (byte->hex.m1 o)
+  (string-drop o 2))
+
+(define (asm->m1 o)
+  (let ((prefix ".byte "))
+    (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
+        (let ((s (string-drop o (string-length prefix))))
+          (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
+
+(define (ident->variable info o)
+  (or (assoc-ref (.locals info) o)
+      (assoc-ref (.statics info) o)
+      (assoc-ref (filter (negate static-global?) (.globals info)) o)
+      (assoc-ref (.constants info) o)
+      (assoc-ref (.functions info) o)
+      (begin
+        (error "ident->variable: undefined variable:" o))))
+
+(define (static-global? o)
+  ((compose global:function cdr) o))
+
+(define (string-global? o)
+  (and (pair? (car o))
+       (eq? (caar o) #:string)))
+
+(define (ident->type info o)
+  (let ((var (ident->variable info o)))
+    (cond ((global? var) (global:type var))
+          ((local? var) (local:type var))
+          ((function? var) (function:type var))
+          ((assoc-ref (.constants info) o) (assoc-ref (.types info) "default"))
+          ((pair? var) (car var))
+          (else (stderr "ident->type ~s => ~s\n" o var)
+                #f))))
+
+(define (local:pointer o)
+  (->rank o))
+
+(define (ident->rank info o)
+  (->rank (ident->variable info o)))
+
+(define (ident->size info o)
+  ((compose type:size (cut ident->type info <>)) o))
+
+(define (pointer->rank o)
+  (pmatch o
+    ((pointer) 1)
+    ((pointer ,pointer) (1+ (pointer->rank pointer)))))
+
+(define (expr->rank info o)
+  (->rank (ast->type o info)))
+
+(define (ast->size o info)
+  (->size (ast->type o info)))
+
+(define (append-text info text)
+  (clone info #:text (append (.text info) text)))
+
+(define (push-global info)
+  (lambda (o)
+    (let ((rank (ident->rank info o)))
+      (cond ((< rank 0) (list (i386:push-label `(#:address ,o)))) ;; FIXME
+            (else (list (i386:push-label-mem `(#:address ,o))))))))
+
+(define (push-local locals)
+  (lambda (o)
+    (wrap-as (i386:push-local (local:id o)))))
+
+(define (push-global-address info)
+  (lambda (o)
+    (list (i386:push-label o))))
+
+(define (push-local-address locals)
+  (lambda (o)
+    (wrap-as (i386:push-local-address (local:id o)))))
+
+(define (push-local-de-ref info)
+  (lambda (o)
+    (let ((size (->size o)))
+      (case size
+        ((1) (wrap-as (i386:push-byte-local-de-ref (local:id o))))
+        ((2) (wrap-as (i386:push-word-local-de-ref (local:id o))))
+        ((4) (wrap-as (i386:push-local-de-ref (local:id o))))
+        (else (error (format #f "TODO: push size >4: ~a\n" size)))))))
+
+ ;; (if (= ptr 2) (ast-type->size info (local:type o)) ;; URG
+ ;;                       4)
+(define (push-local-de-de-ref info)
+  (lambda (o)
+    (let ((size (->size (rank-- (rank-- o)))))
+      (if (= size 1)
+          (wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
+          (error "TODO int-de-de-ref")))))
+
+(define (make-global-entry name type value)
+  (cons name (make-global name type value #f)))
+
+(define (string->global-entry string)
+  (let ((value (append (string->list string) (list #\nul))))
+   (make-global-entry `(#:string ,string) "char" value))) ;; FIXME char-array
+
+(define (make-local-entry name type id)
+  (cons name (make-local name type id)))
+
+(define* (mescc:trace name #:optional (type ""))
+  (format (current-error-port) "    :~a~a\n" name type))
+
+(define (push-ident info)
+  (lambda (o)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (push-local (.locals info)))
+          ((assoc-ref (.statics info) o)
+           =>
+           (push-global info))
+          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
+           =>
+           (push-global info))
+          ((assoc-ref (.constants info) o)
+           =>
+           (lambda (constant)
+             (wrap-as (append (i386:value->accu constant)
+                              (i386:push-accu)))))
+          (else
+           ((push-global-address #f) `(#:address ,o))))))
+
+(define (push-ident-address info)
+  (lambda (o)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (push-local-address (.locals info)))
+          ((assoc-ref (.statics info) o)
+           =>
+           (push-global-address info))
+          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
+           =>
+           (push-global-address info))
+          (else
+           ((push-global-address #f) `(#:address ,o))))))
+
+(define (push-ident-de-ref info)
+  (lambda (o)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (push-local-de-ref info))
+          (else ((push-global info) o)))))
+
+(define (push-ident-de-de-ref info)
+  (lambda (o)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (push-local-de-de-ref info))
+          (else
+           (error "not supported: global push-ident-de-de-ref:" o)))))
+
+(define (expr->arg info)
+  (lambda (o)
+    (pmatch o
+      ((p-expr (string ,string))
+       (let* ((globals ((globals:add-string (.globals info)) string))
+              (info (clone info #:globals globals)))
+         (append-text info ((push-global-address info) `(#:string ,string)))))
+      (_ (let ((info (expr->accu o info)))
+           (append-text info (wrap-as (i386:push-accu))))))))
+
+(define (globals:add-string globals)
+  (lambda (o)
+    (let ((string `(#:string ,o)))
+      (if (assoc-ref globals string) globals
+          (append globals (list (string->global-entry o)))))))
+
+(define (ident->accu info)
+  (lambda (o)
+    (cond ((assoc-ref (.locals info) o) => local->accu)
+          ((assoc-ref (.statics info) o) => global->accu)
+          ((assoc-ref (filter (negate static-global?) (.globals info)) o) => global->accu)
+          ((assoc-ref (.constants info) o) => number->accu)
+          (else (list (i386:label->accu `(#:address ,o)))))))
+
+(define (local->accu o)
+  (let* ((type (local:type o)))
+    (cond ((or (c-array? type)
+               (structured-type? type)) (wrap-as (i386:local-ptr->accu (local:id o))))
+          (else (append (wrap-as (i386:local->accu (local:id o)))
+                        (convert-accu type))))))
+
+(define (global->accu o)
+  (let ((type (global:type o)))
+    (cond ((or (c-array? type)
+               (structured-type? type)) (wrap-as (i386:label->accu `(#:address ,o))))
+          (else (append (wrap-as (i386:label-mem->accu `(#:address ,o)))
+                        (convert-accu type))))))
+
+(define (number->accu o)
+  (wrap-as (i386:value->accu o)))
+
+(define (ident-address->accu info)
+  (lambda (o)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (lambda (local) (wrap-as (i386:local-ptr->accu (local:id local)))))
+          ((assoc-ref (.statics info) o)
+           =>
+           (lambda (global) (list (i386:label->accu `(#:address ,global)))))
+          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
+           =>
+           (lambda (global) (list (i386:label->accu `(#:address ,global)))))
+          (else (list (i386:label->accu `(#:address ,o)))))))
+
+(define (ident-address->base info)
+  (lambda (o)
+    (cond
+     ((assoc-ref (.locals info) o)
+      =>
+      (lambda (local) (wrap-as (i386:local-ptr->base (local:id local)))))
+     ((assoc-ref (.statics info) o)
+      =>
+      (lambda (global) (list (i386:label->base `(#:address ,global)))))
+     ((assoc-ref (filter (negate static-global?) (.globals info)) o)
+      =>
+      (lambda (global) (list (i386:label->base `(#:address ,global)))))
+     (else (list (i386:label->base `(#:address ,o)))))))
+
+(define (value->accu v)
+  (wrap-as (i386:value->accu v)))
+
+(define (accu->local+n-text local n)
+  (let ((id (local:id local))) (wrap-as (i386:accu->local+n id n))))
+
+(define (accu->ident info)
+  (lambda (o)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (lambda (local) (let ((size (->size local)))
+                             (if (<= size 4) (wrap-as (i386:accu->local (local:id local)))
+                                 (wrap-as (i386:accu*n->local (local:id local) size))))))
+          ((assoc-ref (.statics info) o)
+           =>
+           (lambda (global) (let ((size (->size global)))
+                              (if (<= size 4) (wrap-as (i386:accu->label global))
+                                  (wrap-as (i386:accu*n->label global size))))))
+          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
+           =>
+           (lambda (global) (let ((size (->size global)))
+                              (if (<= size 4) (wrap-as (i386:accu->label global))
+                                  (wrap-as (i386:accu*n->label global size)))))))))
+
+(define (value->ident info)
+  (lambda (o value)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (lambda (local) (wrap-as (i386:value->local (local:id local) value))))
+          ((assoc-ref (.statics info) o)
+           =>
+           (lambda (global) (list (i386:value->label `(#:address ,global) value))))
+          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
+           =>
+           (lambda (global) (list (i386:value->label `(#:address ,global) value)))))))
+
+(define (ident-add info)
+  (lambda (o n)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (lambda (local) (wrap-as (i386:local-add (local:id local) n))))
+          ((assoc-ref (.statics info) o)
+           =>
+           (lambda (global) (list (i386:label-mem-add `(#:address ,o) n))))
+          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
+           =>
+           (lambda (global) (list (i386:label-mem-add `(#:address ,global) n)))))))
+
+(define (ident-address-add info)
+  (lambda (o n)
+    (cond ((assoc-ref (.locals info) o)
+           =>
+           (lambda (local) (wrap-as (append (i386:push-accu)
+                                            (i386:local->accu (local:id local))
+                                            (i386:accu-mem-add n)
+                                            (i386:pop-accu)))))
+          ((assoc-ref (.statics info) o)
+           =>
+           (lambda (global) (list (wrap-as (append (i386:push-accu)
+                                                   (i386:label->accu `(#:address ,global))
+                                                   (i386:accu-mem-add n)
+                                                   (i386:pop-accu))))))
+          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
+           =>
+           (lambda (global) (list (wrap-as (append (i386:push-accu)
+                                                   (i386:label->accu `(#:address ,global))
+                                                   (i386:accu-mem-add n)
+                                                   (i386:pop-accu)))))))))
+
+(define (make-comment o)
+  (wrap-as `((#:comment ,o))))
+
+(define (ast->comment o)
+  (if mes? '()
+      (let* ((source (with-output-to-string (lambda () (pretty-print-c99 o))))
+             ;; Nyacc 0.80.42 fixups
+             (source (string-substitute source "'\\'" "'\\\\'"))
+             (source (string-substitute source "'\"'" "'\\\"'"))
+             (source (string-substitute source "'''" "'\\''")))
+        (make-comment (string-join (string-split source #\newline) " ")))))
+
+(define (accu*n info n)
+  (append-text info (wrap-as (case n
+                               ((1) (i386:accu->base))
+                               ((2) (i386:accu+accu))
+                               ((3) (append (i386:accu->base)
+                                            (i386:accu+accu)
+                                            (i386:accu+base)))
+                               ((4) (i386:accu-shl 2))
+                               ((8) (append (i386:accu+accu)
+                                            (i386:accu-shl 2)))
+                               ((12) (append (i386:accu->base)
+                                             (i386:accu+accu)
+                                             (i386:accu+base)
+                                             (i386:accu-shl 2)))
+                               ((16) (i386:accu-shl 4))
+                               (else (append (i386:value->base n)
+                                             (i386:accu*base)))))))
+
+(define (accu->base-mem*n- info n)
+  (wrap-as
+   (case n
+     ((1) (i386:byte-accu->base-mem))
+     ((2) (i386:word-accu->base-mem))
+     ((4) (i386:accu->base-mem))
+     (else (append (let loop ((i 0))
+                     (if (>= i n) '()
+                         (append (if (= i 0) '()
+                                     (append (i386:accu+value 4)
+                                             (i386:base+value 4)))
+                                 (case (- n i)
+                                   ((1) (append (i386:accu+value -3)
+                                                (i386:base+value -3)
+                                                (i386:accu-mem->base-mem)))
+                                   ((2) (append (i386:accu+value -2)
+                                                (i386:base+value -2)
+                                                (i386:accu-mem->base-mem)))
+                                   ((3) (append (i386:accu+value -1)
+                                                (i386:base+value -1)
+                                                (i386:accu-mem->base-mem)))
+                                   (else (i386:accu-mem->base-mem)))
+                                 (loop (+ i 4))))))))))
+
+(define (accu->base-mem*n info n)
+  (append-text info (accu->base-mem*n- info n)))
+
+(define (expr->accu* o info)
+  (pmatch o
+
+    ((p-expr (ident ,name))
+     (append-text info ((ident-address->accu info) name)))
+
+    ((de-ref ,expr)
+     (expr->accu expr info))
+
+    ((d-sel (ident ,field) ,struct)
+     (let* ((type (ast->basic-type struct info))
+            (offset (field-offset info type field))
+            (info (expr->accu* struct info)))
+       (append-text info (wrap-as (i386:accu+value offset)))))
+
+    ((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest))
+     (let* ((type (ast->basic-type `(fctn-call (p-expr (ident ,function)) ,@rest) info))
+            (offset (field-offset info type field))
+            (info (expr->accu `(fctn-call (p-expr (ident ,function)) ,@rest) info)))
+       (append-text info (wrap-as (i386:accu+value offset)))))
+
+    ((i-sel (ident ,field) ,struct)
+     (let* ((type (ast->basic-type struct info))
+            (offset (field-offset info type field))
+            (info (expr->accu* struct info)))
+       (append-text info (append (wrap-as (i386:mem->accu))
+                                 (wrap-as (i386:accu+value offset))))))
+
+    ((array-ref ,index ,array)
+     (let* ((info (expr->accu index info))
+            (size (ast->size o info))
+            (info (accu*n info size))
+            (info (expr->base array info)))
+       (append-text info (wrap-as (i386:accu+base)))))
+
+    ((cast ,type ,expr)
+     (expr->accu `(ref-to ,expr) info))
+
+    ((add ,a ,b)
+     (let* ((rank (expr->rank info a))
+            (rank-b (expr->rank info b))
+            (type (ast->basic-type a info))
+            (struct? (structured-type? type))
+            (size (cond ((= rank 1) (ast-type->size info a))
+                        ((> rank 1) 4)
+                        ((and struct? (= rank 2)) 4)
+                        (else 1))))
+       (if (or (= size 1)) ((binop->accu* info) a b (i386:accu+base))
+           (let* ((info (expr->accu b info))
+                  (info (append-text info (wrap-as (append (i386:value->base size)
+                                                           (i386:accu*base)
+                                                           (i386:accu->base)))))
+                  (info (expr->accu* a info)))
+             (append-text info (wrap-as (i386:accu+base)))))))
+
+    ((sub ,a ,b)
+     (let* ((rank (expr->rank info a))
+            (rank-b (expr->rank info b))
+            (type (ast->basic-type a info))
+            (struct? (structured-type? type))
+            (size (->size type))
+            (size  (cond ((= rank 1) size)
+                         ((> rank 1) 4)
+                         ((and struct? (= rank 2)) 4)
+                         (else 1))))
+       (if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
+           (let ((info ((binop->accu* info) a b (i386:accu-base))))
+             (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
+                 (append-text info (wrap-as (append (i386:value->base size)
+                                                    (i386:accu/base))))))
+           (let* ((info (expr->accu* b info))
+                  (info (append-text info (wrap-as (append (i386:value->base size)
+                                                           (i386:accu*base)
+                                                           (i386:accu->base)))))
+                  (info (expr->accu* a info)))
+             (append-text info (wrap-as (i386:accu-base)))))))
+
+    ((pre-dec ,expr)
+     (let* ((rank (expr->rank info expr))
+            (size (cond ((= rank 1) (ast-type->size info expr))
+                        ((> rank 1) 4)
+                        (else 1)))
+            (info ((expr-add info) expr (- size)))
+            (info (append (expr->accu* expr info))))
+       info))
+
+    ((pre-inc ,expr)
+     (let* ((rank (expr->rank info expr))
+            (size (cond ((= rank 1) (ast-type->size info expr))
+                        ((> rank 1) 4)
+                        (else 1)))
+            (info ((expr-add info) expr size))
+            (info (append (expr->accu* expr info))))
+       info))
+
+    ((post-dec ,expr)
+     (let* ((info (expr->accu* expr info))
+            (info (append-text info (wrap-as (i386:push-accu))))
+            (post (clone info #:text '()))
+            (post (append-text post (ast->comment o)))
+            (post (append-text post (wrap-as (i386:pop-base))))
+            (post (append-text post (wrap-as (i386:push-accu))))
+            (post (append-text post (wrap-as (i386:base->accu))))
+            (rank (expr->rank post expr))
+            (size (cond ((= rank 1) (ast-type->size post expr))
+                        ((> rank 1) 4)
+                        (else 1)))
+            (post ((expr-add post) expr (- size)))
+            (post (append-text post (wrap-as (i386:pop-accu)))))
+       (clone info #:post (.text post))))
+
+    ((post-inc ,expr)
+     (let* ((info (expr->accu* expr info))
+            (info (append-text info (wrap-as (i386:push-accu))))
+            (post (clone info #:text '()))
+            (post (append-text post (ast->comment o)))
+            (post (append-text post (wrap-as (i386:pop-base))))
+            (post (append-text post (wrap-as (i386:push-accu))))
+            (post (append-text post (wrap-as (i386:base->accu))))
+            (rank (expr->rank post expr))
+            (size (cond ((= rank 1) (ast-type->size post expr))
+                        ((> rank 1) 4)
+                        (else 1)))
+            (post ((expr-add post) expr size))
+            (post (append-text post (wrap-as (i386:pop-accu)))))
+       (clone info #:post (.text post))))
+
+    (_ (error "expr->accu*: not supported: " o))))
+
+(define (expr-add info)
+  (lambda (o n)
+    (let* ((info (expr->accu* o info))
+           (info (append-text info (wrap-as (i386:accu-mem-add n)))))
+      info)))
+
+(define (expr->accu o info)
+  (let ((locals (.locals info))
+        (text (.text info))
+        (globals (.globals info)))
+    (define (helper)
+      (pmatch o
+        ((expr) info)
+
+        ((comma-expr) info)
+
+        ((comma-expr ,a . ,rest)
+         (let ((info (expr->accu a info)))
+           (expr->accu `(comma-expr ,@rest) info)))
+
+        ((p-expr (string ,string))
+         (let* ((globals ((globals:add-string globals) string))
+                (info (clone info #:globals globals)))
+           (append-text info (list (i386:label->accu `(#:string ,string))))))
+
+        ((p-expr (string . ,strings))
+         (let* ((string (apply string-append strings))
+                (globals ((globals:add-string globals) string))
+                (info (clone info #:globals globals)))
+           (append-text info (list (i386:label->accu `(#:string ,string))))))
+
+        ((p-expr (fixed ,value))
+         (let ((value (cstring->int value)))
+           (append-text info (wrap-as (i386:value->accu value)))))
+
+        ((p-expr (float ,value))
+         (let ((value (cstring->float value)))
+           (append-text info (wrap-as (i386:value->accu value)))))
+
+        ((neg (p-expr (fixed ,value)))
+         (let ((value (- (cstring->int value))))
+           (append-text info (wrap-as (i386:value->accu value)))))
+
+        ((p-expr (char ,char))
+         (let ((char (char->integer (car (string->list char)))))
+           (append-text info (wrap-as (i386:value->accu char)))))
+
+        (,char (guard (char? char)) (append-text info (wrap-as (i386:value->accu char))))
+
+        ((p-expr (ident ,name))
+         (append-text info ((ident->accu info) name)))
+
+        ((initzer ,initzer)
+         (expr->accu initzer info))
+
+        (((initzer ,initzer))
+         (expr->accu initzer info))
+
+        ;; offsetoff
+        ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
+         (let* ((type (ast->basic-type struct info))
+                (offset (field-offset info type field))
+                (base (cstring->int base)))
+           (append-text info (wrap-as (i386:value->accu (+ base offset))))))
+
+        ;; &foo
+        ((ref-to (p-expr (ident ,name)))
+         (append-text info ((ident-address->accu info) name)))
+
+        ;; &*foo
+        ((ref-to (de-ref ,expr))
+         (expr->accu expr info))
+
+        ((ref-to ,expr)
+         (expr->accu* expr info))
+
+        ((sizeof-expr ,expr)
+         (append-text info (wrap-as (i386:value->accu (ast->size expr info)))))
+
+        ((sizeof-type ,type)
+         (append-text info (wrap-as (i386:value->accu (ast->size type info)))))
+
+        ((array-ref ,index ,array)
+         (let* ((info (expr->accu* o info))
+                (type (ast->type o info)))
+           (append-text info (mem->accu type))))
+
+        ((d-sel ,field ,struct)
+         (let* ((info (expr->accu* o info))
+                (info (append-text info (ast->comment o)))
+                (type (ast->type o info))
+                (size (->size type))
+                (array? (c-array? type)))
+           (if array? info
+               (append-text info (mem->accu type)))))
+
+        ((i-sel ,field ,struct)
+         (let* ((info (expr->accu* o info))
+                (info (append-text info (ast->comment o)))
+                (type (ast->type o info))
+                (size (->size type))
+                (array? (c-array? type)))
+           (if array? info
+               (append-text info (mem->accu type)))))
+
+        ((de-ref ,expr)
+         (let* ((info (expr->accu expr info))
+                (type (ast->type o info)))
+           (append-text info (mem->accu type))))
+
+        ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
+         (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
+                                   (append-text info (wrap-as (asm->m1 arg0))))
+             (let* ((text-length (length text))
+                    (args-info (let loop ((expressions (reverse expr-list)) (info info))
+                                 (if (null? expressions) info
+                                     (loop (cdr expressions) ((expr->arg info) (car expressions))))))
+                    (n (length expr-list)))
+               (if (not (assoc-ref locals name))
+                   (begin
+                     (if (and (not (assoc name (.functions info)))
+                              (not (assoc name globals))
+                              (not (equal? name (.function info))))
+                         (stderr "warning: undeclared function: ~a\n" name))
+                     (append-text args-info (list (i386:call-label name n))))
+                   (let* ((empty (clone info #:text '()))
+                          (accu (expr->accu `(p-expr (ident ,name)) empty)))
+                     (append-text args-info (append (.text accu)
+                                                    (list (i386:call-accu n)))))))))
+
+        ((fctn-call ,function (expr-list . ,expr-list))
+         (let* ((text-length (length text))
+                (args-info (let loop ((expressions (reverse expr-list)) (info info))
+                             (if (null? expressions) info
+                                 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
+                (n (length expr-list))
+                (empty (clone info #:text '()))
+                (accu (expr->accu function empty)))
+           (append-text args-info (append (.text accu)
+                                          (list (i386:call-accu n))))))
+
+        ((cond-expr . ,cond-expr)
+         (ast->info `(expr-stmt ,o) info))
+
+        ((post-inc ,expr)
+         (let* ((info (append (expr->accu expr info)))
+                (info (append-text info (wrap-as (i386:push-accu))))
+                (rank (expr->rank info expr))
+                (size (cond ((= rank 1) (ast-type->size info expr))
+                            ((> rank 1) 4)
+                            (else 1)))
+                (info ((expr-add info) expr size))
+                (info (append-text info (wrap-as (i386:pop-accu)))))
+           info))
+
+        ((post-dec ,expr)
+         (let* ((info (append (expr->accu expr info)))
+                (info (append-text info (wrap-as (i386:push-accu))))
+                (rank (expr->rank info expr))
+                (size (cond ((= rank 1) (ast-type->size info expr))
+                            ((> rank 1) 4)
+                            (else 1)))
+                (info ((expr-add info) expr (- size)))
+                (info (append-text info (wrap-as (i386:pop-accu)))))
+           info))
+
+        ((pre-inc ,expr)
+         (let* ((rank (expr->rank info expr))
+                (size (cond ((= rank 1) (ast-type->size info expr))
+                            ((> rank 1) 4)
+                            (else 1)))
+                (info ((expr-add info) expr size))
+                (info (append (expr->accu expr info))))
+           info))
+
+        ((pre-dec ,expr)
+         (let* ((rank (expr->rank info expr))
+                (size (cond ((= rank 1) (ast-type->size info expr))
+                            ((> rank 1) 4)
+                            (else 1)))
+                (info ((expr-add info) expr (- size)))
+                (info (append (expr->accu expr info))))
+           info))
+
+
+
+        ((add ,a (p-expr (fixed ,value)))
+         (let* ((rank (expr->rank info a))
+                (type (ast->basic-type a info))
+                (struct? (structured-type? type))
+                (size (cond ((= rank 1) (ast-type->size info a))
+                            ((> rank 1) 4)
+                            ((and struct? (= rank 2)) 4)
+                            (else 1)))
+                (info (expr->accu a info))
+                (value (cstring->int value))
+                (value (* size value)))
+           (append-text info (wrap-as (i386:accu+value value)))))
+
+        ((add ,a ,b)
+         (let* ((rank (expr->rank info a))
+                (rank-b (expr->rank info b))
+                (type (ast->basic-type a info))
+                (struct? (structured-type? type))
+                (size (cond ((= rank 1) (ast-type->size info a))
+                            ((> rank 1) 4)
+                            ((and struct? (= rank 2)) 4)
+                            (else 1))))
+           (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base))
+               (let* ((info (expr->accu b info))
+                      (info (append-text info (wrap-as (append (i386:value->base size)
+                                                               (i386:accu*base)
+                                                               (i386:accu->base)))))
+                      (info (expr->accu a info)))
+                 (append-text info (wrap-as (i386:accu+base)))))))
+
+        ((sub ,a (p-expr (fixed ,value)))
+         (let* ((rank (expr->rank info a))
+                (type (ast->basic-type a info))
+                (struct? (structured-type? type))
+                (size (->size type))
+                (size (cond ((= rank 1) size)
+                            ((> rank 1) 4)
+                            ((and struct? (= rank 2)) 4)
+                            (else 1)))
+                (info (expr->accu a info))
+                (value (cstring->int value))
+                (value (* size value)))
+           (append-text info (wrap-as (i386:accu+value (- value))))))
+
+        ((sub ,a ,b)
+         (let* ((rank (expr->rank info a))
+                (rank-b (expr->rank info b))
+                (type (ast->basic-type a info))
+                (struct? (structured-type? type))
+                (size (->size type))
+                (size  (cond ((= rank 1) size)
+                             ((> rank 1) 4)
+                             ((and struct? (= rank 2)) 4)
+                             (else 1))))
+           (if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
+               (let ((info ((binop->accu info) a b (i386:accu-base))))
+                 (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
+                     (append-text info (wrap-as (append (i386:value->base size)
+                                                        (i386:accu/base))))))
+               (let* ((info (expr->accu b info))
+                      (info (append-text info (wrap-as (append (i386:value->base size)
+                                                               (i386:accu*base)
+                                                               (i386:accu->base)))))
+                      (info (expr->accu a info)))
+                 (append-text info (wrap-as (i386:accu-base)))))))
+
+        ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
+        ((bitwise-not ,expr)
+         (let ((info (ast->info expr info)))
+           (append-text info (wrap-as (i386:accu-not)))))
+        ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
+        ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base)))
+        ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
+        ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
+        ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
+        ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
+        ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
+
+        ((not ,expr)
+         (let* ((test-info (ast->info expr info)))
+           (clone info #:text
+                  (append (.text test-info)
+                          (wrap-as (i386:accu-negate)))
+                  #:globals (.globals test-info))))
+
+        ((neg ,expr)
+         (let ((info (expr->base expr info)))
+           (append-text info (append (wrap-as (i386:value->accu 0))
+                                     (wrap-as (i386:sub-base))))))
+
+        ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu))))
+
+        ((ge ,a ,b)
+         (let* ((type-a (ast->type a info))
+                (type-b (ast->type b info))
+                (test->accu (if (or (unsigned? type-a) (unsigned? type-b)) i386:ae?->accu i386:ge?->accu)))
+           ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
+
+        ((gt ,a ,b)
+         (let* ((type-a (ast->type a info))
+                (type-b (ast->type b info))
+                (test->accu (if (or (unsigned? type-a) (unsigned? type-b)) i386:a?->accu i386:g?->accu)))
+           ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
+
+        ;; FIXME: set accu *and* flags
+        ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu)
+                                                    (i386:sub-base)
+                                                    (i386:nz->accu)
+                                                    (i386:accu<->stack)
+                                                    (i386:sub-base)
+                                                    (i386:xor-zf)
+                                                    (i386:pop-accu))))
+
+        ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf))))
+
+        ((le ,a ,b)
+         (let* ((type-a (ast->type a info))
+                (type-b (ast->type b info))
+                (test->accu (if (or (unsigned? type-a) (unsigned? type-b)) i386:be?->accu i386:le?->accu)))
+           ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
+
+        ((lt ,a ,b)
+         (let* ((type-a (ast->type a info))
+                (type-b (ast->type b info))
+                (test->accu (if (or (unsigned? type-a) (unsigned? type-b)) i386:b?->accu i386:l?->accu)))
+           ((binop->accu info) a b (append (i386:sub-base) (test->accu) (i386:accu-test)))))
+
+        ((or ,a ,b)
+         (let* ((info (expr->accu a info))
+                (here (number->string (length (.text info))))
+                (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b"))
+                (info (append-text info (wrap-as (i386:accu-test))))
+                (info (append-text info (wrap-as (i386:jump-nz skip-b-label))))
+                (info (append-text info (wrap-as (i386:accu-test))))
+                (info (expr->accu b info))
+                (info (append-text info (wrap-as (i386:accu-test))))
+                (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
+           info))
+
+        ((and ,a ,b)
+         (let* ((info (expr->accu a info))
+                (here (number->string (length (.text info))))
+                (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b"))
+                (info (append-text info (wrap-as (i386:accu-test))))
+                (info (append-text info (wrap-as (i386:jump-z skip-b-label))))
+                (info (append-text info (wrap-as (i386:accu-test))))
+                (info (expr->accu b info))
+                (info (append-text info (wrap-as (i386:accu-test))))
+                (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
+           info))
+
+        ((cast ,type ,expr)
+         (let ((info (expr->accu expr info))
+               (type (ast->type o info)))
+           (append-text info (convert-accu type))))
+
+        ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
+         (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
+                (type (ident->type info name))
+                (rank (ident->rank info name))
+                (size (if (> rank 1) 4 1)))
+           (append-text info ((ident-add info) name size))))
+
+        ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
+         (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
+                (type (ident->type info name))
+                (rank (ident->rank info name))
+                (size (if (> rank 1) 4 1)))
+           (append-text info ((ident-add info) name (- size)))))
+
+        ((assn-expr ,a (op ,op) ,b)
+         (let* ((info (append-text info (ast->comment o)))
+                (type (ast->type a info))
+                (rank (->rank type))
+                (type-b (ast->type b info))
+                (rank-b (->rank type-b))
+                (size (if (zero? rank) (->size type) 4))
+                (size-b (if (zero? rank-b) (->size type-b) 4))
+                (info (expr->accu b info))
+                (info (if (equal? op "=") info
+                          (let* ((struct? (structured-type? type))
+                                 (size (cond ((= rank 1) (ast-type->size info a))
+                                             ((> rank 1) 4)
+                                             ((and struct? (= rank 2)) 4)
+                                             (else 1)))
+                                 (info (if (or (= size 1) (= rank-b 1)) info
+                                           (let ((info (append-text info (wrap-as (i386:value->base size)))))
+                                             (append-text info (wrap-as (i386:accu*base))))))
+                                 (info (append-text info (wrap-as (i386:push-accu))))
+                                 (info (expr->accu a info))
+                                 (info (append-text info (wrap-as (i386:pop-base))))
+                                 (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
+                                                               ((equal? op "-=") (wrap-as (i386:accu-base)))
+                                                               ((equal? op "*=") (wrap-as (i386:accu*base)))
+                                                               ((equal? op "/=") (wrap-as (i386:accu/base)))
+                                                               ((equal? op "%=") (wrap-as (i386:accu%base)))
+                                                               ((equal? op "&=") (wrap-as (i386:accu-and-base)))
+                                                               ((equal? op "|=") (wrap-as (i386:accu-or-base)))
+                                                               ((equal? op "^=") (wrap-as (i386:accu-xor-base)))
+                                                               ((equal? op ">>=") (wrap-as (i386:accu>>base)))
+                                                               ((equal? op "<<=") (wrap-as (i386:accu<<base)))
+                                                               (else (error (format #f "mescc: op ~a not supported: ~a\n" op o)))))))
+                            (cond ((not (and (= rank 1) (= rank-b 1))) info)
+                                  ((equal? op "-=") (append-text info (wrap-as (append (i386:value->base size)
+                                                                                       (i386:accu/base)))))
+                                  (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type (ast->basic-type b info)))))))))
+           (when (and (equal? op "=")
+                      (not (= size size-b))
+                      (not (and (or (= size 1) (= size 2))
+                                (or (= size-b 2) (= size-b 4))))
+                      (not (and (= size 2)
+                                (= size-b 4)))
+                      (not (and (= size 4)
+                                (or (= size-b 1) (= size-b 2)))))
+             (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o))))
+             (stderr "   size[~a]:~a != size[~a]:~a\n"  rank size rank-b size-b))
+           (pmatch a
+             ((p-expr (ident ,name))
+              (if (or (<= size 4) ;; FIXME: long long = int
+                      (<= size-b 4)) (append-text info ((accu->ident info) name))
+                      (let ((info (expr->base* a info)))
+                        (accu->base-mem*n info size))))
+             (_ (let* ((info (expr->base* a info))
+                       (info (if (not (bit-field? type)) info
+                                 (let* ((bit (bit-field:bit type))
+                                        (bits (bit-field:bits type))
+                                        (set-mask (- (ash bits 1) 1))
+                                        (shifted-set-mask (ash set-mask bit))
+                                        (clear-mask (logxor shifted-set-mask #b11111111111111111111111111111111))
+                                        (info (append-text info (wrap-as (i386:push-base))))
+                                        (info (append-text info (wrap-as (i386:push-accu))))
+
+                                        (info (append-text info (wrap-as (i386:base-mem->accu))))
+                                        (info (append-text info (wrap-as (i386:accu-and clear-mask))))
+                                        (info (append-text info (wrap-as (i386:accu->base))))
+
+                                        (info (append-text info (wrap-as (i386:pop-accu))))
+                                        (info (append-text info (wrap-as (i386:accu-and set-mask))))
+                                        (info (append-text info (wrap-as (i386:accu-shl bit))))
+                                        (info (append-text info (wrap-as (i386:accu-or-base))))
+
+                                        (info (append-text info (wrap-as (i386:pop-base)))))
+                                   info))))
+                  (accu->base-mem*n info (min size (max 4 size-b)))))))) ;; FIXME: long long = int
+
+        (_ (error "expr->accu: not supported: " o))))
+
+    (let ((info (helper)))
+      (if (null? (.post info)) info
+          (append-text (clone info #:post '()) (.post info))))))
+
+(define (mem->accu type)
+  (let ((size (->size type)))
+    (case size
+      ((1) (append (wrap-as (i386:byte-mem->accu)) (convert-accu type)))
+      ((2) (append (wrap-as (i386:word-mem->accu)) (convert-accu type)))
+      ((4) (wrap-as (i386:mem->accu)))
+      (else '()))))
+
+(define (convert-accu type)
+  (if (not (type? type)) '()
+      (let ((sign (signed? type))
+            (size (->size type)))
+        (cond ((and (= size 1) sign)
+               (wrap-as (i386:signed-byte-accu)))
+              ((= size 1)
+               (wrap-as (i386:byte-accu)))
+              ((and (= size 2) sign)
+               (wrap-as (i386:signed-word-accu)))
+              ((= size 1)
+               (wrap-as (i386:word-accu)))
+              (else '())))))
+
+(define (expr->base o info)
+  (let* ((info (append-text info (wrap-as (i386:push-accu))))
+         (info (expr->accu o info))
+         (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
+    info))
+
+(define (binop->accu info)
+  (lambda (a b c)
+    (let* ((info (expr->accu a info))
+           (info (expr->base b info)))
+      (append-text info (wrap-as c)))))
+
+(define (binop->accu* info)
+  (lambda (a b c)
+    (let* ((info (expr->accu* a info))
+           (info (expr->base b info)))
+      (append-text info (wrap-as c)))))
+
+(define (wrap-as o . annotation)
+  `(,@annotation ,o))
+
+(define (expr->base* o info)
+  (let* ((info (append-text info (wrap-as (i386:push-accu))))
+         (info (expr->accu* o info))
+         (info (append-text info (wrap-as (i386:accu->base))))
+         (info (append-text info (wrap-as (i386:pop-accu)))))
+    info))
+
+(define (comment? o)
+  (and (pair? o) (pair? (car o)) (eq? (caar o) #:comment)))
+
+(define (test-jump-label->info info label)
+  (define (jump type . test)
+    (lambda (o)
+      (let* ((info (ast->info o info))
+             (info (append-text info (make-comment "jmp test LABEL")))
+             (jump-text (wrap-as (type label))))
+        (append-text info (append (if (null? test) '() (car test))
+                                  jump-text)))))
+  (lambda (o)
+    (pmatch o
+      ((expr) info)
+      ((le ,a ,b) ((jump i386:jump-z) o))
+      ((lt ,a ,b) ((jump i386:jump-z) o))
+      ((ge ,a ,b) ((jump i386:jump-z) o))
+      ((gt ,a ,b) ((jump i386:jump-z) o))
+      ((ne ,a ,b) ((jump i386:jump-nz) o))
+      ((eq ,a ,b) ((jump i386:jump-nz) o))
+      ((not _) ((jump i386:jump-z) o))
+
+      ((and ,a ,b)
+       (let* ((info ((test-jump-label->info info label) a))
+              (info ((test-jump-label->info info label) b)))
+         info))
+
+      ((or ,a ,b)
+       (let* ((here (number->string (length (if mes? (.text info)
+                                                (filter (negate comment?) (.text info))))))
+              (skip-b-label (string-append label "_skip_b_" here))
+              (b-label (string-append label "_b_" here))
+              (info ((test-jump-label->info info b-label) a))
+              (info (append-text info (wrap-as (i386:jump skip-b-label))))
+              (info (append-text info (wrap-as `((#:label ,b-label)))))
+              (info ((test-jump-label->info info label) b))
+              (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
+         info))
+
+      ((array-ref ,index ,expr) (let* ((rank (expr->rank info expr))
+                                       (size (if (= rank 1) (ast-type->size info expr)
+                                                 4)))
+                                  ((jump (if (= size 1) i386:jump-byte-z
+                                             i386:jump-z)
+                                         (wrap-as (i386:accu-zero?))) o)))
+
+      ((de-ref ,expr) (let* ((rank (expr->rank info expr))
+                             (size (if (= rank 1) (ast-type->size info expr)
+                                       4)))
+                        ((jump (if (= size 1) i386:jump-byte-z
+                                   i386:jump-z)
+                               (wrap-as (i386:accu-zero?))) o)))
+
+      ((assn-expr (p-expr (ident ,name)) ,op ,expr)
+       ((jump i386:jump-z
+              (append ((ident->accu info) name)
+                      (wrap-as (i386:accu-zero?)))) o))
+
+      (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
+
+(define (cstring->int o)
+  (let ((o (cond ((string-suffix? "ULL" o) (string-drop-right o 3))
+                 ((string-suffix? "UL" o) (string-drop-right o 2))
+                 ((string-suffix? "LL" o) (string-drop-right o 2))
+                 ((string-suffix? "L" o) (string-drop-right o 1))
+                 (else o))))
+    (or (cond ((string-prefix? "0x" o) (string->number (string-drop o 2) 16))
+              ((string-prefix? "0b" o) (string->number (string-drop o 2) 2))
+              ((string-prefix? "0" o) (string->number o 8))
+              (else (string->number o)))
+        (error "cstring->int: not supported:" o))))
+
+(define (cstring->float o)
+  (or (string->number o)
+      (error "cstring->float: not supported:" o)))
+
+(define (try-expr->number info o)
+  (pmatch o
+    ((fixed ,a) (cstring->int a))
+    ((p-expr ,expr) (expr->number info expr))
+    ((neg ,a)
+     (- (expr->number info a)))
+    ((add ,a ,b)
+     (+ (expr->number info a) (expr->number info b)))
+    ((bitwise-and ,a ,b)
+     (logand (expr->number info a) (expr->number info b)))
+    ((bitwise-not ,a)
+     (lognot (expr->number info a)))
+    ((bitwise-or ,a ,b)
+     (logior (expr->number info a) (expr->number info b)))
+    ((div ,a ,b)
+     (quotient (expr->number info a) (expr->number info b)))
+    ((mul ,a ,b)
+     (* (expr->number info a) (expr->number info b)))
+    ((sub ,a ,b)
+     (- (expr->number info a) (expr->number info b)))
+    ((sizeof-type ,type)
+     (->size (ast->type type info)))
+    ((sizeof-expr ,expr)
+     (->size (ast->type expr info)))
+    ((lshift ,x ,y)
+     (ash (expr->number info x) (expr->number info y)))
+    ((rshift ,x ,y)
+     (ash (expr->number info x) (- (expr->number info y))))
+    ((p-expr (ident ,name))
+     (let ((value (assoc-ref (.constants info) name)))
+       (or value
+           (error (format #f "expr->number: undeclared identifier: ~s\n" o)))))
+    ((cast ,type ,expr) (expr->number info expr))
+    ((cond-expr ,test ,then ,else)
+     (if (p-expr->bool info test) (expr->number info then) (expr->number info else)))
+    (,string (guard (string? string)) (cstring->int string))
+    ((ident ,name) (assoc-ref (.constants info) name))
+    (_  #f)))
+
+(define (expr->number info o)
+  (or (try-expr->number info  o)
+      (error (format #f "expr->number: not supported: ~s\n" o))))
+
+(define (p-expr->bool info o)
+  (pmatch o
+    ((eq ,a ,b) (eq? (expr->number info a) (expr->number info b)))))
+
+(define (struct-field info)
+  (lambda (o)
+    (pmatch o
+      ((comp-decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))) (comp-declr-list . ,decls))
+       (let (
+             ;;(constants (enum-def-list->constants (.constants info) fields))
+             ;;(type-entry (enum->type-entry name fields))
+             )
+         (append-map (lambda (o)
+                       ((struct-field info) `(comp-decl (decl-spec-list (type-spec "int")) (comp-declr-list ,o))))
+                     decls)))
+    ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ident ,name))))
+       (list (cons name (ast->type type info))))
+      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (ident ,name)))))
+       (let ((rank (pointer->rank pointer)))
+         (list (cons name (rank+= (ast->type type info) rank)))))
+      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr ,pointer (ident ,name))) _))))
+       (let ((rank (pointer->rank pointer)))
+         (list (cons name (rank+= (ast->type type info) rank)))))
+      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (array-of (ident ,name) ,count)))))
+       (let ((rank (pointer->rank pointer))
+             (count (expr->number info count)))
+         (list (cons name (make-c-array (rank+= type rank) count)))))
+      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
+       (let ((count (expr->number info count)))
+         (list (cons name (make-c-array (ast->type type info) count)))))
+      ((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
+       (let ((fields (append-map (struct-field info) fields)))
+         (list (cons 'struct (make-type 'struct (apply + (map field:size fields)) fields)))))
+      ((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
+       (let ((fields (append-map (struct-field info) fields)))
+         (list (cons 'union (make-type 'union (apply + (map field:size fields)) fields)))))
+      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields))
+       (let ((type (ast->type type info)))
+         (list (cons 'bits (let loop ((o `((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields)) (bit 0))
+                             (if (null? o) '()
+                                 (let ((field (car o)))
+                                   (pmatch field
+                                     ((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits))))
+                                      (let ((bits (cstring->int bits)))
+                                        (cons (cons name (make-bit-field type bit bits))
+                                              (loop (cdr o) (+ bit bits)))))
+                                     (_ (error "struct-field: not supported:" field o))))))))))
+      ((comp-decl (decl-spec-list ,type) (comp-declr-list . ,decls))
+       (append-map (lambda (o)
+                     ((struct-field info) `(comp-decl (decl-spec-list ,type) (comp-declr-list ,o))))
+                   decls))
+      (_ (error "struct-field: not supported: " o)))))
+
+(define (local-var? o) ;; formals < 0, locals > 0
+  (positive? (local:id o)))
+
+(define (ptr-declr->rank o)
+  (pmatch o
+    ((pointer) 1)
+    ((pointer (pointer)) 2)
+    ((pointer (pointer (pointer))) 3)
+    (_ (error "ptr-declr->rank not supported: " o))))
+
+(define (ast->info o info)
+  (let ((functions (.functions info))
+        (globals (.globals info))
+        (locals (.locals info))
+        (constants (.constants info))
+        (types (.types info))
+        (text (.text info)))
+    (pmatch o
+      (((trans-unit . _) . _) (ast-list->info o info))
+      ((trans-unit . ,_) (ast-list->info _ info))
+      ((fctn-defn . ,_) (fctn-defn->info _ info))
+
+      ((cpp-stmt (define (name ,name) (repl ,value)))
+       info)
+
+      ((cast (type-name (decl-spec-list (type-spec (void)))) _)
+       info)
+
+      ((break)
+       (let ((label (car (.break info))))
+         (append-text info (wrap-as (i386:jump label)))))
+
+      ((continue)
+       (let ((label (car (.continue info))))
+         (append-text info (wrap-as (i386:jump label)))))
+
+      ;; FIXME: expr-stmt wrapper?
+      (trans-unit info)
+      ((expr-stmt) info)
+
+      ((compd-stmt (block-item-list . ,_)) (ast-list->info _ info))
+
+      ((asm-expr ,gnuc (,null ,arg0 . string))
+       (append-text info (wrap-as (asm->m1 arg0))))
+
+      ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
+       (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
+                                 (append-text info (wrap-as (asm->m1 arg0))))
+           (let* ((info (append-text info (ast->comment o)))
+                  (info (expr->accu `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) info)))
+             (append-text info (wrap-as (i386:accu-zero?))))))
+
+      ((if ,test ,then)
+       (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
+              (here (number->string (length text)))
+              (label (string-append "_" (.function info) "_" here "_"))
+              (break-label (string-append label "break"))
+              (else-label (string-append label "else"))
+              (info ((test-jump-label->info info break-label) test))
+              (info (ast->info then info))
+              (info (append-text info (wrap-as (i386:jump break-label))))
+              (info (append-text info (wrap-as `((#:label ,break-label))))))
+         (clone info
+                #:locals locals)))
+
+      ((if ,test ,then ,else)
+       (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
+              (here (number->string (length text)))
+              (label (string-append "_" (.function info) "_" here "_"))
+              (break-label (string-append label "break"))
+              (else-label (string-append label "else"))
+              (info ((test-jump-label->info info else-label) test))
+              (info (ast->info then info))
+              (info (append-text info (wrap-as (i386:jump break-label))))
+              (info (append-text info (wrap-as `((#:label ,else-label)))))
+              (info (ast->info else info))
+              (info (append-text info (wrap-as `((#:label ,break-label))))))
+         (clone info
+                #:locals locals)))
+
+      ;; Hmm?
+      ((expr-stmt (cond-expr ,test ,then ,else))
+       (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
+              (here (number->string (length text)))
+              (label (string-append "_" (.function info) "_" here "_"))
+              (else-label (string-append label "else"))
+              (break-label (string-append label "break"))
+              (info ((test-jump-label->info info else-label) test))
+              (info (ast->info then info))
+              (info (append-text info (wrap-as (i386:jump break-label))))
+              (info (append-text info (wrap-as `((#:label ,else-label)))))
+              (info (ast->info else info))
+              (info (append-text info (wrap-as `((#:label ,break-label))))))
+         info))
+
+      ((switch ,expr (compd-stmt (block-item-list . ,statements)))
+       (define (clause? o)
+         (pmatch o
+           ((case . _) 'case)
+           ((default . _) 'default)
+           ((labeled-stmt _ ,statement) (clause? statement))
+           (_ #f)))
+       (define clause-number
+         (let ((i 0))
+           (lambda (o)
+             (let ((n i))
+               (when (clause? (car o))
+                 (set! i (1+ i)))
+               n))))
+       (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
+              (here (number->string (length text)))
+              (label (string-append "_" (.function info) "_" here "_"))
+              (break-label (string-append label "break"))
+              (info (expr->accu expr info))
+              (info (clone info #:break (cons break-label (.break info))))
+              (count (length (filter clause? statements)))
+              (default? (find (cut eq? <> 'default) (map clause? statements)))
+              (info (fold (cut switch->info #t label (1- count) <> <> <>) info statements
+                          (unfold null? clause-number cdr statements)))
+              (last-clause-label (string-append label "clause" (number->string count)))
+              (default-label (string-append label "default"))
+              (info (if (not default?) info
+                        (append-text info (wrap-as (i386:jump break-label)))))
+              (info (append-text info (wrap-as `((#:label ,last-clause-label)))))
+              (info (if (not default?) info
+                        (append-text info (wrap-as (i386:jump default-label)))))
+              (info (append-text info (wrap-as `((#:label ,break-label))))))
+         (clone info
+                #:locals locals
+                #:break (cdr (.break info)))))
+
+      ((for ,init ,test ,step ,body)
+       (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
+              (here (number->string (length text)))
+              (label (string-append "_" (.function info) "_" here "_"))
+              (break-label (string-append label "break"))
+              (loop-label (string-append label "loop"))
+              (continue-label (string-append label "continue"))
+              (initial-skip-label (string-append label "initial_skip"))
+              (info (ast->info init info))
+              (info (clone info #:break (cons break-label (.break info))))
+              (info (clone info #:continue (cons continue-label (.continue info))))
+              (info (append-text info (wrap-as (i386:jump initial-skip-label))))
+              (info (append-text info (wrap-as `((#:label ,loop-label)))))
+              (info (ast->info body info))
+              (info (append-text info (wrap-as `((#:label ,continue-label)))))
+              (info (expr->accu step info))
+              (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
+              (info ((test-jump-label->info info break-label) test))
+              (info (append-text info (wrap-as (i386:jump loop-label))))
+              (info (append-text info (wrap-as `((#:label ,break-label))))))
+         (clone info
+                #:locals locals
+                #:break (cdr (.break info))
+                #:continue (cdr (.continue info)))))
+
+      ((while ,test ,body)
+       (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
+              (here (number->string (length text)))
+              (label (string-append "_" (.function info) "_" here "_"))
+              (break-label (string-append label "break"))
+              (loop-label (string-append label "loop"))
+              (continue-label (string-append label "continue"))
+              (info (append-text info (wrap-as (i386:jump continue-label))))
+              (info (clone info #:break (cons break-label (.break info))))
+              (info (clone info #:continue (cons continue-label (.continue info))))
+              (info (append-text info (wrap-as `((#:label ,loop-label)))))
+              (info (ast->info body info))
+              (info (append-text info (wrap-as `((#:label ,continue-label)))))
+              (info ((test-jump-label->info info break-label) test))
+              (info (append-text info (wrap-as (i386:jump loop-label))))
+              (info (append-text info (wrap-as `((#:label ,break-label))))))
+         (clone info
+                #:locals locals
+                #:break (cdr (.break info))
+                #:continue (cdr (.continue info)))))
+
+      ((do-while ,body ,test)
+       (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
+              (here (number->string (length text)))
+              (label (string-append "_" (.function info) "_" here "_"))
+              (break-label (string-append label "break"))
+              (loop-label (string-append label "loop"))
+              (continue-label (string-append label "continue"))
+              (info (clone info #:break (cons break-label (.break info))))
+              (info (clone info #:continue (cons continue-label (.continue info))))
+              (info (append-text info (wrap-as `((#:label ,loop-label)))))
+              (info (ast->info body info))
+              (info (append-text info (wrap-as `((#:label ,continue-label)))))
+              (info ((test-jump-label->info info break-label) test))
+              (info (append-text info (wrap-as (i386:jump loop-label))))
+              (info (append-text info (wrap-as `((#:label ,break-label))))))
+         (clone info
+                #:locals locals
+                #:break (cdr (.break info))
+                #:continue (cdr (.continue info)))))
+
+      ((labeled-stmt (ident ,label) ,statement)
+       (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" label)))))))
+         (ast->info statement info)))
+
+      ((goto (ident ,label))
+       (append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label)))))
+
+      ((return ,expr)
+       (let ((info (expr->accu expr info)))
+         (append-text info (append (wrap-as (i386:ret))))))
+
+      ((decl . ,decl)
+       ;;FIXME: ridiculous performance hit with mes
+       ;; Nyacc 0.80.42: missing  (enum-ref (ident "fred"))
+       (let ( ;;(info (append-text info (ast->comment o)))
+             )
+         (decl->info info decl)))
+      ;; ...
+      ((gt . _) (expr->accu o info))
+      ((ge . _) (expr->accu o info))
+      ((ne . _) (expr->accu o info))
+      ((eq . _) (expr->accu o info))
+      ((le . _) (expr->accu o info))
+      ((lt . _) (expr->accu o info))
+      ((lshift . _) (expr->accu o info))
+      ((rshift . _) (expr->accu o info))
+
+      ;; EXPR
+      ((expr-stmt ,expression)
+       (let ((info (expr->accu expression info)))
+         (append-text info (wrap-as (i386:accu-zero?)))))
+
+      ;; FIXME: why do we get (post-inc ...) here
+      ;; (array-ref
+      (_ (let ((info (expr->accu o info)))
+           (append-text info (wrap-as (i386:accu-zero?))))))))
+
+(define (ast-list->info o info)
+  (fold ast->info info o))
+
+(define (switch->info clause? label count o i info)
+  (let* ((i-string (number->string i))
+         (i+1-string (number->string (1+ i)))
+         (body-label (string-append label "body" i-string))
+         (clause-label (string-append label "clause" i-string))
+         (last? (= i count))
+         (break-label (string-append label "break"))
+         (next-clause-label (string-append label "clause" i+1-string))
+         (default-label (string-append label "default")))
+    (define (jump label)
+      (wrap-as (i386:jump label)))
+    (pmatch o
+      ((case ,test)
+       (define (jump-nz label)
+         (wrap-as (i386:jump-nz label)))
+       (define (jump-z label)
+         (wrap-as (i386:jump-z label)))
+       (define (test->text test)
+         (let ((value (pmatch test
+                        (0 0)
+                        ((p-expr (char ,value)) (char->integer (car (string->list value))))
+                        ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
+