* build.sh: Rewrite.
* build-aux/build-cc.sh: New file.
* build-aux/build-mes.sh: New file.
* build-aux/build-mlibc.sh: New file.
* build-aux/cc.sh: New file.
* build-aux/cc-mes.sh: New file.
* build-aux/cc-mlibc.sh: New file.
* install.sh: Update.
* make.scm: Remove.
* guile/guix/make.scm: Remove.
* guile/guix/records.scm: Remove.
* guile/guix/shell-utilsg.scm: Remove.
*-
+*.blood-elf-M1
+*.blood-elf-hex2
*.go
*~
.#*
/.tarball-version
/ChangeLog
/a.out
+*.gcc-out
*.mes-out
+*.mlibc-out
+*.seed-out
#keep this: bootstrap
#/mes.mes
export PREFIX
export VERSION
-PHONY_TARGETS:= all all-go check clean clean-go default help install list
+PHONY_TARGETS:= all all-go check clean clean-go default help install
.PHONY: $(PHONY_TARGETS)
-$(PHONY_TARGETS):
- $(GUILE) $(GUILE_FLAGS) -s make.scm $@
+default: all
-%:
- $(GUILE) $(GUILE_FLAGS) -s make.scm $@
+all:
+ ./build.sh
+
+clean:
+ true
+
+all-go:
+ build-aux/build-guile.sh
+
+clean-go:
+ rm -f $(shell find . -name '*.go')
+
+check:
+ ./check.sh
+
+
+install:
+ ./install.sh
.config.make: ./configure
+
+seed:
+ cd ../mes-seed && git reset --hard HEAD
+ MES=guile GUILE=guile SEED=1 build-aux/build-mes.sh
+ cd ../mes-seed && ./bootstrap.sh && cd ../mes
+ MES=guile GUILE=guile SEED=1 build-aux/build-mes.sh
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+set -ex
+
+export CC=${CC-gcc}
+
+build-aux/mes-snarf.scm src/gc.c
+build-aux/mes-snarf.scm src/lib.c
+build-aux/mes-snarf.scm src/math.c
+build-aux/mes-snarf.scm src/mes.c
+build-aux/mes-snarf.scm src/posix.c
+build-aux/mes-snarf.scm src/reader.c
+build-aux/mes-snarf.scm src/vector.c
+
+export CPPFLAGS=${CPPFLAGS-"
+-D VERSION=\"$VERSION\"
+-D MODULEDIR=\"$MODULEDIR\"
+-D PREFIX=\"$PREFIX\"
+-I src
+-I lib
+-I include
+"}
+
+export CFLAGS=${CFLAGS-"
+--std=gnu99
+-O0
+-g
+"}
+
+NOLINK=1 sh build-aux/cc.sh lib/libc-gcc
+#NOLINK=1 sh build-aux/cc.sh lib/libc+tcc-gcc
+
+sh build-aux/cc.sh src/mes
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+set -ex
+
+export GUILE=${GUILE-$(type -p guile)}
+
+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/M1.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
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+set -ex
+
+export HEX2=${HEX2-hex2}
+export M1=${M1-M1}
+export BLOOD_ELF=${BLOOD_ELF-blood-elf}
+export MES_SEED=${MES_SEED-../mes-seed}
+export MESCC=${MESCC-$(type -p mescc)}
+[ -z "$MESCC" ] && MESCC=scripts/mescc
+export MES=${MES-$(type -p mes)}
+[ -z "$MES" ] && MES=src/mes
+
+if [ -d "$MES_SEED" ]; then
+ $M1 --LittleEndian --Architecture=1\
+ -f stage0/x86.M1\
+ -f $MES_SEED/crt1.M1\
+ -o lib/crt1.hex2
+ $M1 --LittleEndian --Architecture=1\
+ -f stage0/x86.M1\
+ -f $MES_SEED/libc-mes.M1\
+ -o lib/libc-mes.hex2
+ $M1 --LittleEndian --Architecture=1\
+ -f stage0/x86.M1\
+ -f $MES_SEED/mes.M1\
+ -o src/mes.hex2
+ $BLOOD_ELF\
+ -f stage0/x86.M1\
+ -f $MES_SEED/mes.M1\
+ -f $MES_SEED/libc-mes.M1\
+ -o src/mes.blood-elf.M1
+ $M1 --LittleEndian --Architecture=1\
+ -f src/mes.blood-elf.M1\
+ -o src/mes.blood-elf.hex2
+ $HEX2 --LittleEndian --Architecture=1 --BaseAddress=0x1000000\
+ -f stage0/elf32-header.hex2\
+ -f lib/crt1.hex2\
+ -f lib/libc-mes.hex2\
+ -f src/mes.hex2\
+ -f src/mes.blood-elf.hex2\
+ --exec_enable\
+ -o src/mes.seed-out
+ cp src/mes.seed-out src/mes
+
+ $M1 --LittleEndian --Architecture=1 -f\
+ stage0/x86.M1\
+ -f $MES_SEED/libc+tcc-mes.M1\
+ -o src/libc+tcc-mes.hex2
+fi
+
+[ -n "$SEED" ] && exit 0
+
+export GUILE=src/mes
+export 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
+sh build-aux/mes-snarf.scm --mes src/math.c
+sh build-aux/mes-snarf.scm --mes src/mes.c
+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
+
+export 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-mes
+NOLINK=1 sh build-aux/cc-mes.sh lib/libc+tcc-mes
+
+# 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
+
+sh build-aux/cc-mes.sh src/mes
+# FIXME: broken
+# cp src/mes.mes-out src/mes
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+set -ex
+
+export CC32=${CC32-$(type -p i686-unknown-linux-gnu-gcc)}
+build-aux/mes-snarf.scm --mes src/gc.c
+build-aux/mes-snarf.scm --mes src/lib.c
+build-aux/mes-snarf.scm --mes src/math.c
+build-aux/mes-snarf.scm --mes src/mes.c
+build-aux/mes-snarf.scm --mes src/posix.c
+build-aux/mes-snarf.scm --mes src/reader.c
+build-aux/mes-snarf.scm --mes src/vector.c
+
+build-aux/mes-snarf.scm src/gc.c
+build-aux/mes-snarf.scm src/lib.c
+build-aux/mes-snarf.scm src/math.c
+build-aux/mes-snarf.scm src/mes.c
+build-aux/mes-snarf.scm src/posix.c
+build-aux/mes-snarf.scm src/reader.c
+build-aux/mes-snarf.scm src/vector.c
+
+export CPPFLAGS=${CPPFLAGS-"
+-D VERSION=\"$VERSION\"
+-D MODULEDIR=\"$MODULEDIR\"
+-D PREFIX=\"$PREFIX\"
+-I src
+-I lib
+-I include
+"}
+
+export C32FLAGS=${C32FLAGS-"
+--std=gnu99
+-O0
+-fno-stack-protector
+-g
+-m32
+-nostdinc
+-nostdlib
+"}
+
+NOLINK=1 sh build-aux/cc-mlibc.sh lib/crt1
+NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-gcc
+NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc+tcc-gcc
+
+sh build-aux/cc-mlibc.sh scaffold/main
+sh build-aux/cc-mlibc.sh scaffold/hello
+sh build-aux/cc-mlibc.sh scaffold/argv
+sh build-aux/cc-mlibc.sh scaffold/malloc
+sh build-aux/cc-mlibc.sh scaffold/micro-mes
+sh build-aux/cc-mlibc.sh scaffold/tiny-mes
+sh build-aux/cc-mlibc.sh scaffold/mini-mes
+
+sh build-aux/cc-mlibc.sh src/mes
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+set -ex
+
+export HEX2=${HEX2-hex2}
+export M1=${M1-M1}
+export BLOOD_ELF=${BLOOD_ELF-blood-elf}
+export MES_SEED=${MES_SEED-../mes-seed}
+export MESCC=${MESCC-$(type -p mescc)}
+[ -z "$MESCC" ] && MESCC=scripts/mescc
+export MES=${MES-$(type -p mes)}
+[ -z "$MES" ] && MES=src/mes
+
+CPPFLAGS=${CPPFLAGS-"
+-D VERSION=\"$VERSION\"
+-D MODULEDIR=\"$MODULEDIR\"
+-D PREFIX=\"$PREFIX\"
+-I src
+-I lib
+-I include
+"}
+
+MESCCLAGS=${MESCCFLAGS-"
+"}
+
+c=$1
+
+if [ -n "$PREPROCESS" ]; then
+ sh -x $MESCC\
+ -E\
+ $CPPFLAGS\
+ $MESCCFLAGS\
+ -o "$c".E\
+ "$c".c
+ sh -x $MESCC\
+ -c\
+ -o "$c".M1\
+ "$c".E
+else
+ sh -x $MESCC\
+ -c\
+ $CPPFLAGS\
+ $MESCCFLAGS\
+ -o "$c".M1\
+ "$c".c
+fi
+
+$M1 --LittleEndian --Architecture=1\
+ -f stage0/x86.M1\
+ -f "$c".M1\
+ -o "$c".hex2
+
+if [ -z "$NOLINK" ]; then
+ $BLOOD_ELF\
+ -f stage0/x86.M1\
+ -f "$c".M1\
+ -f lib/libc-mes.M1\
+ -o "$c".blood-elf-M1
+ $M1 --LittleEndian --Architecture=1\
+ -f "$c".blood-elf-M1\
+ -o "$c".blood-elf-hex2
+ $HEX2 --LittleEndian --Architecture=1 --BaseAddress=0x1000000\
+ -f stage0/elf32-header.hex2\
+ -f lib/crt1.hex2\
+ -f lib/libc-mes.hex2\
+ -f "$c".hex2\
+ -f "$c".blood-elf-hex2\
+ --exec_enable\
+ -o "$c".mes-out
+fi
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+set -ex
+
+CPPFLAGS=${CPPFLAGS-"
+-D VERSION=\"$VERSION\"
+-D MODULEDIR=\"$MODULEDIR\"
+-D PREFIX=\"$PREFIX\"
+-I src
+-I lib
+-I include
+"}
+
+C32FLAGS=${C32FLAGS-"
+--std=gnu99
+-O0
+-fno-builtin
+-fno-stack-protector
+-g
+-m32
+-nostdinc
+-nostdlib
+"}
+
+c=$1
+
+$CC32\
+ -c\
+ $CPPFLAGS\
+ $C32FLAGS\
+ -o "$c".mlibc-o\
+ "$c".c
+
+if [ -z "$NOLINK" ]; then
+ $CC32\
+ $C32FLAGS\
+ -o "$c".mlibc-out\
+ lib/crt1.mlibc-o\
+ "$c".mlibc-o\
+ lib/libc-gcc.mlibc-o
+fi
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+set -ex
+
+CPPFLAGS=${CPPFLAGS-"
+-D VERSION=\"$VERSION\"
+-D MODULEDIR=\"$MODULEDIR\"
+-D PREFIX=\"$PREFIX\"
+-I src
+-I lib
+-I include
+"}
+
+CFLAGS=${CFLAGS-"
+--std=gnu99
+-O0
+-g
+"}
+
+c=$1
+
+$CC\
+ -c\
+ $CPPFLAGS\
+ $CFLAGS\
+ -D POSIX=1\
+ -o "$c".gcc-o\
+ "$c".c
+
+if [ -z "$NOLINK" ]; then
+ $CC\
+ $CFLAGS\
+ -o "$c".gcc-out\
+ "$c".gcc-o\
+ lib/libc-gcc.gcc-o
+fi
--- /dev/null
+#! /bin/bash
+
+# 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/>.
+
+set -e
+
+export GUILE=${GUILE-guile}
+export MES=${MES-./src/mes}
+
+tests="
+
+00-zero.scm
+01-true.scm
+02-symbol.scm
+03-string.scm
+04-quote.scm
+05-list.scm
+06-tick.scm
+07-if.scm
+08-if-if.scm
+
+10-cons.scm
+11-list.scm
+12-car.scm
+13-cdr.scm
+14-exit.scm
+15-display.scm
+
+16-if-eq-quote.scm
+
+20-define.scm
+20-define-quoted.scm
+20-define-quote.scm
+
+21-define-procedure.scm
+22-define-procedure-2.scm
+23-begin.scm
+24-begin-define.scm
+25-begin-define-2.scm
+26-begin-define-later.scm
+27-lambda-define.scm
+28-define-define.scm
+29-lambda-define.scm
+2a-lambda-lambda.scm
+2b-define-lambda.scm
+2c-define-lambda-recurse.scm
+2d-define-lambda-set.scm
+2d-compose.scm
+2e-define-first.scm
+2f-define-second.scm
+2f-define-second-lambda.scm
+2g-vector.scm
+
+30-capture.scm
+31-capture-define.scm
+32-capture-modify-close.scm
+32-capture-modify-close.scm
+33-procedure-override-close.scm
+34-cdr-override-close.scm
+35-closure-modify.scm
+36-closure-override.scm
+37-closure-lambda.scm
+38-simple-format.scm
+39-global-define-override.scm
+3a-global-define-lambda-override.scm
+
+40-define-macro.scm
+41-when.scm
+42-if-when.scm
+43-or.scm
+44-or-if.scm
+45-pass-if.scm
+46-report.scm
+47-pass-if-eq.scm
+48-let.scm
+49-macro-override.scm
+4a-define-macro-define-macro.scm
+4b-define-macro-define.scm
+4c-quasiquote.scm
+4d-let-map.scm
+4e-let-global.scm
+
+50-primitive-load.scm
+51-module.scm
+52-define-module.scm
+53-closure-display.scm
+
+60-let-syntax.scm
+"
+
+for i in $tests; do
+ echo -n $i
+ if [ ! -f scaffold/boot/$i ]; then
+ echo ' [SKIP]'
+ continue;
+ fi
+ $GUILE -L guile -L . <(echo '(use-modules (mes guile))'; cat scaffold/boot/$i) >& /dev/null
+ x=$(
+ if [ -z "${i/5[0-9]-*/}" ]; then
+ cat scaffold/boot/$i | MES_BOOT=boot-00.scm $MES 2>&1;
+ elif [ -z "${i/6[0-9]-*/}" ]; then
+ cat scaffold/boot/$i | MES_BOOT=boot-01.scm $MES 2>&1;
+ else
+ MES_BOOT=scaffold/boot/$i $MES 2>&1;
+ fi
+ ) \
+ && echo ' [PASS]' \
+ || (r=$?; echo ' [FAIL]'; echo -e "$x"; echo scaffold/boot/$i; exit $r)
+done
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+export MES=${MES-src/mes}
+export MESCC=${MESCC-scripts/mescc}
+export GUILE=${GUILE-guile}
+export MES_PREFIX=${MES_PREFIX-.}
+
+export HEX2=${HEX2-hex2}
+export M1=${M1-M1}
+export BLOOD_ELF=${BLOOD_ELF-blood-elf}
+export MES_SEED=${MES_SEED-../mes-seed}
+export MESCC=${MESCC-$(type -p mescc)}
+[ -z "$MESCC" ] && MESCC=scripts/mescc
+export MES=${MES-$(type -p mes)}
+[ -z "$MES" ] && MES=src/mes
+
+
+tests="
+t
+00-exit-0
+01-return-0
+02-return-1
+03-call
+04-call-0
+05-call-1
+06-call-!1
+10-if-0
+11-if-1
+12-if-==
+13-if-!=
+14-if-goto
+15-if-!f
+16-if-t
+20-while
+21-char[]
+22-while-char[]
+23-pointer
+30-strlen
+31-eputs
+32-compare
+33-and-or
+34-pre-post
+35-compare-char
+36-compare-arithmetic
+37-compare-assign
+38-compare-call
+40-if-else
+41-?
+42-goto-label
+43-for-do-while
+44-switch
+45-void-call
+50-assert
+51-strcmp
+52-itoa
+53-strcpy
+54-argv
+60-math
+61-array
+63-struct-cell
+64-make-cell
+65-read
+70-printf
+71-struct-array
+72-typedef-struct-def
+73-union
+74-multi-line-string
+75-struct-union
+76-pointer-arithmetic
+77-pointer-assign
+78-union-struct
+79-int-array
+7a-struct-char-array
+7b-struct-int-array
+7c-dynarray
+7d-cast-char
+7e-struct-array-access
+7f-struct-pointer-arithmetic
+7g-struct-byte-word-field
+7h-struct-assign
+7i-struct-struct
+7j-strtoull
+7k-for-each-elem
+7l-struct-any-size-array
+7m-struct-char-array-assign
+7n-struct-struct-array
+80-setjmp
+81-qsort
+82-define
+"
+
+if [ ! -x ./i686-unknown-linux-gnu-tcc ]; then
+ tests=$(echo "$tests" | grep -Ev "02-return-1|05-call-1|80-setjmp|81-qsort")
+fi
+
+set +e
+fail=0
+total=0
+for t in $tests; do
+ sh build-aux/test.sh "scaffold/tests/$t" &> scaffold/tests/"$t".log
+ r=$?
+ total=$((total+1))
+ if [ $r = 0 ]; then
+ echo $t: [OK]
+ else
+ echo $t: [FAIL]
+ fail=$((fail+1))
+ fi
+done
+
+tests="
+00_assignment
+01_comment
+02_printf
+03_struct
+04_for
+05_array
+06_case
+07_function
+08_while
+09_do_while
+
+10_pointer
+11_precedence
+12_hashdefine
+
+14_if
+15_recursion
+16_nesting
+17_enum
+18_include
+19_pointer_arithmetic
+
+20_pointer_comparison
+21_char_array
+
+
+
+25_quicksort
+
+
+29_array_address
+
+
+31_args
+
+
+33_ternary_op
+35_sizeof
+
+
+
+
+
+
+41_hashif
+
+43_void_param
+44_scoped_declarations
+45_empty_for
+
+47_switch_return
+48_nested_break
+
+
+50_logical_second_arg
+
+
+54_goto
+
+"
+
+#13_integer_literals ; fail
+#22_floating_point ; float
+#23_type_coercion ; float
+#24_math_library ; float
+#27_sizeof ; float
+#28_strings ; TODO: strncpy strchr strrchr memset memcpy memcmp
+#30_hanoi ; fails with GCC
+#32_led ; unsupported: (decl (decl-spec-list (stor-spec (static)) (type-spec (fixed-type "int"))) (init-declr-list (init-declr (array-of (ident "d") (p-expr (fixed "32"))))))
+#34_array_assignment ; fails with GCC
+#36_array_initialisers ; unspported: (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (array-of (ident "Array") (p-expr (fixed "10"))) (initzer (initzer-list (initzer (p-expr (fixed "12"))) (initzer (p-expr (fixed "34"))) (initzer (p-expr (fixed "56"))) (initzer (p-expr (fixed "78"))) (initzer (p-expr (fixed "90"))) (initzer (p-expr (fixed "123"))) (initzer (p-expr (fixed "456"))) (initzer (p-expr (fixed "789"))) (initzer (p-expr (fixed "8642"))) (initzer (p-expr (fixed "9753"))))))))
+#37_sprintf ; integer formatting unsupported
+#38_multiple_array_index ; unspported: (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (array-of (array-of (ident "a") (p-expr (fixed "4"))) (p-expr (fixed "4"))))))
+#39_typedef ;unsupported: (decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename "MyFunStruct"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "MoreFunThanEver")))))
+
+#40_stdio ; f* functions
+#42_function_pointer ; f* functions
+#46_grep ; f* functions
+#49_bracket_evaluation ; float
+#51_static ; unsupported: (decl (decl-spec-list (stor-spec (static)) (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "fred") (initzer (p-expr (fixed "1234"))))))
+#52_unnamed_enum ; unsupported: (decl (decl-spec-list (stor-spec (typedef)) (type-spec (enum-def (enum-def-list (enum-defn (ident "e")) (enum-defn (ident "f")) (enum-defn (ident "g")))))) (init-declr-list (init-declr (ident "h"))))
+#55_lshift_type ; unsigned
+
+
+# FIXME: have no diff
+tests=
+for t in $tests; do
+ if [ ! -f scaffold/tinycc/"$t.c" ]; then
+ echo ' [SKIP]'
+ continue;
+ fi
+ sh build-aux/test.sh "scaffold/tinycc/$t" &> scaffold/tinycc/"$t".log
+ r=$?
+ total=$((total+1))
+ if [ $r = 0 ]; then
+ echo $t: [OK]
+ else
+ echo $t: [FAIL]
+ fail=$((fail+1))
+ fi
+done
+
+if [ $fail != 0 ]; then
+ echo FAILED: $fail/$total
+ exit 1
+else
+ echo PASS: $total
+fi
(define %gcc? #t)
-(define-record-type file (make-file name content)
+(define-record-type <file> (make-file name content)
file?
(name file.name)
(content file.content))
-(define-record-type function (make-function name formals annotation)
+(define-record-type <function> (make-function name formals annotation)
function?
(name function.name)
(formals function.formals)
--- /dev/null
+#! /bin/sh
+
+# 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/>.
+
+set -ex
+
+t=${1-scaffold/tests/t}
+#rm -f "$t".i686-unknown-linux-gnu-out
+rm -f "$t".mes-out
+
+sh build-aux/cc-mes.sh "$t"
+
+r=0
+set +e
+"$t".mes-out | tee "$t".stdout
+m=$?
+
+[ $m = $r ]
+if [ -f "$t".expect ]; then
+ diff -u "$t".expect "$t".stdout;
+fi
set -ex
-HEX2=${HEX2-hex2}
-M1=${M1-M1}
-BLOOD_ELF=${BLOOD_ELF-blood-elf}
-MES_SEED=${MES_SEED-../mes-seed}
+export CC=${CC-$(type -p gcc)}
+export CC32=${CC32-$(type -p i686-unknown-linux-gnu-gcc)}
+export MESCC=${MESCC-$(type -p mescc)}
+export MES_SEED=${MES_SEED-../mes-seed}
+export GUILE=${GUILE-$(type -p guile)}
+export MES_ARENA=${MES_ARENA-300000000}
+export MES_DEBUG=${MES_DEBUG-2}
-$M1 --LittleEndian --Architecture=1\
- -f stage0/x86.M1\
- -f $MES_SEED/crt1.M1\
- -o crt1.hex2
-$M1 --LittleEndian --Architecture=1\
- -f stage0/x86.M1\
- -f $MES_SEED/libc-mes.M1\
- -o libc-mes.hex2
-$M1 --LittleEndian --Architecture=1\
- -f stage0/x86.M1\
- -f $MES_SEED/mes.M1\
- -o mes.hex2
-$BLOOD_ELF\
- -f stage0/x86.M1\
- -f $MES_SEED/mes.M1\
- -f $MES_SEED/libc-mes.M1\
- -o mes-blood-elf-footer.M1
-$M1 --LittleEndian --Architecture=1\
- -f mes-blood-elf-footer.M1\
- -o mes-blood-elf-footer.hex2
-$HEX2 --LittleEndian --Architecture=1 --BaseAddress=0x1000000\
- -f stage0/elf32-header.hex2\
- -f crt1.hex2\
- -f libc-mes.hex2\
- -f mes.hex2\
- -f mes-blood-elf-footer.hex2\
- --exec_enable\
- -o src/mes
+export PREFIX=${PREFIX-/usr/local}
+export DATADIR=${DATADIR-$PREFIX/share/mes}
+export MODULEDIR=${MODULEDIR-$DATADIR/module}
-$M1 --LittleEndian --Architecture=1 -f\
- stage0/x86.M1\
- -f $MES_SEED/libc+tcc-mes.M1\
- -o libc+tcc-mes.hex2
-cp crt1.hex2 lib
-cp libc-mes.hex2 lib
-cp libc+tcc-mes.hex2 lib
+if [ -n "$GUILE" ]; then
+ sh build-aux/build-guile.sh
+fi
-# TODO: after building from seed, build from src/mes.c
-# build-aux/mes-snarf.scm --mes src/gc.c
-# build-aux/mes-snarf.scm --mes src/lib.c
-# build-aux/mes-snarf.scm --mes src/math.c
-# build-aux/mes-snarf.scm --mes src/mes.c
-# build-aux/mes-snarf.scm --mes src/posix.c
-# build-aux/mes-snarf.scm --mes src/reader.c
-# build-aux/mes-snarf.scm --mes src/vector.c
+if [ -n "$CC" ]; then
+ sh build-aux/build-cc.sh
+ cp src/mes.gcc-out src/mes
+fi
+
+if [ -n "$CC32" ]; then
+ sh build-aux/build-mlibc.sh
+ cp src/mes.mlibc-out src/mes
+fi
+
+sh build-aux/build-mes.sh
+++ /dev/null
-#! /bin/bash
-
-# 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/>.
-
-set -e
-
-export GUILE=${GUILE-guile}
-export MES=${MES-./src/mes}
-
-tests="
-
-00-zero.scm
-01-true.scm
-02-symbol.scm
-03-string.scm
-04-quote.scm
-05-list.scm
-06-tick.scm
-07-if.scm
-08-if-if.scm
-
-10-cons.scm
-11-list.scm
-12-car.scm
-13-cdr.scm
-14-exit.scm
-15-display.scm
-
-16-if-eq-quote.scm
-
-20-define.scm
-20-define-quoted.scm
-20-define-quote.scm
-
-21-define-procedure.scm
-22-define-procedure-2.scm
-23-begin.scm
-24-begin-define.scm
-25-begin-define-2.scm
-26-begin-define-later.scm
-27-lambda-define.scm
-28-define-define.scm
-29-lambda-define.scm
-2a-lambda-lambda.scm
-2b-define-lambda.scm
-2c-define-lambda-recurse.scm
-2d-define-lambda-set.scm
-2d-compose.scm
-2e-define-first.scm
-2f-define-second.scm
-2f-define-second-lambda.scm
-2g-vector.scm
-
-30-capture.scm
-31-capture-define.scm
-32-capture-modify-close.scm
-32-capture-modify-close.scm
-33-procedure-override-close.scm
-34-cdr-override-close.scm
-35-closure-modify.scm
-36-closure-override.scm
-37-closure-lambda.scm
-38-simple-format.scm
-39-global-define-override.scm
-3a-global-define-lambda-override.scm
-
-40-define-macro.scm
-41-when.scm
-42-if-when.scm
-43-or.scm
-44-or-if.scm
-45-pass-if.scm
-46-report.scm
-47-pass-if-eq.scm
-48-let.scm
-49-macro-override.scm
-4a-define-macro-define-macro.scm
-4b-define-macro-define.scm
-4c-quasiquote.scm
-4d-let-map.scm
-4e-let-global.scm
-
-50-primitive-load.scm
-51-module.scm
-52-define-module.scm
-53-closure-display.scm
-
-60-let-syntax.scm
-"
-
-for i in $tests; do
- echo -n $i
- if [ ! -f scaffold/boot/$i ]; then
- echo ' [SKIP]'
- continue;
- fi
- $GUILE -L guile -L . <(echo '(use-modules (mes guile))'; cat scaffold/boot/$i) >& /dev/null
- x=$(
- if [ -z "${i/5[0-9]-*/}" ]; then
- cat scaffold/boot/$i | MES_BOOT=boot-00.scm $MES 2>&1;
- elif [ -z "${i/6[0-9]-*/}" ]; then
- cat scaffold/boot/$i | MES_BOOT=boot-01.scm $MES 2>&1;
- else
- MES_BOOT=scaffold/boot/$i $MES 2>&1;
- fi
- ) \
- && echo ' [PASS]' \
- || (r=$?; echo ' [FAIL]'; echo -e "$x"; echo scaffold/boot/$i; exit $r)
-done
+++ /dev/null
-#! /bin/sh
-
-# 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/>.
-
-export MES=${MES-src/mes}
-export MESCC=${MESCC-scripts/mescc}
-#export MES_ARENA=${MES_ARENA-200000000} > 12GB mem
-
-GUILE=${GUILE-guile}
-MES=${MES-src/mes}
-M1=${M1-M1}
-HEX2=${HEX2-hex2}
-MES_PREFIX=${MES_PREFIX-.}
-
-# $MESCC -E -o lib/crt1.E lib/crt1.c
-# $MESCC -c -o lib/crt1.M1 lib/crt1.E
-# $M1 --LittleEndian --Architecture=1 \
-# -f stage0/x86.M1\
-# -f lib/crt1.M1\
-# > lib/crt1.hex2
-# $MESCC -E -o lib/libc-mes.E lib/libc-mes.c
-# $MESCC -c -o lib/libc-mes.M1 lib/libc-mes.E
-# $M1 --LittleEndian --Architecture=1\
-# -f stage0/x86.M1\
-# -f lib/libc-mes.M1\
-# > lib/libc-mes.hex2
-
-tests="
-t
-00-exit-0
-01-return-0
-02-return-1
-03-call
-04-call-0
-05-call-1
-06-call-!1
-10-if-0
-11-if-1
-12-if-==
-13-if-!=
-14-if-goto
-15-if-!f
-16-if-t
-20-while
-21-char[]
-22-while-char[]
-23-pointer
-30-strlen
-31-eputs
-32-compare
-33-and-or
-34-pre-post
-35-compare-char
-36-compare-arithmetic
-37-compare-assign
-38-compare-call
-40-if-else
-41-?
-42-goto-label
-43-for-do-while
-44-switch
-45-void-call
-50-assert
-51-strcmp
-52-itoa
-53-strcpy
-54-argv
-60-math
-61-array
-63-struct-cell
-64-make-cell
-65-read
-70-printf
-71-struct-array
-72-typedef-struct-def
-73-union
-74-multi-line-string
-75-struct-union
-76-pointer-arithmetic
-77-pointer-assign
-78-union-struct
-79-int-array
-7a-struct-char-array
-7b-struct-int-array
-7c-dynarray
-7d-cast-char
-7e-struct-array-access
-7f-struct-pointer-arithmetic
-7g-struct-byte-word-field
-7h-struct-assign
-7i-struct-struct
-7j-strtoull
-7k-for-each-elem
-7l-struct-any-size-array
-7m-struct-char-array-assign
-7n-struct-struct-array
-80-setjmp
-81-qsort
-82-define
-"
-
-if [ ! -x ./i686-unknown-linux-gnu-tcc ]; then
- tests=$(echo "$tests" | grep -Ev "02-return-1|05-call-1|80-setjmp|81-qsort")
-fi
-
-set +e
-fail=0
-total=0
-for t in $tests; do
- sh test.sh "$t" &> scaffold/tests/$t.log
- r=$?
- total=$((total+1))
- if [ $r = 0 ]; then
- echo $t: [OK]
- else
- echo $t: [FAIL]
- fail=$((fail+1))
- fi
-done
-if [ $fail != 0 ]; then
- echo FAILED: $fail/$total
- exit 1
-else
- echo PASS: $total
-fi
export GUILE=${GUILE-guile}
export MES=${MES-src/mes}
-#export MES_ARENA=${MES_ARENA-200000000} #9GiB
+export MES_ARENA=${MES_ARENA-100000000}
set -e
-bash check-boot.sh
+bash build-aux/check-boot.sh
tests="
tests/boot.test
echo PASS: $total
fi
-sh check-mescc.sh
+sh build-aux/check-mescc.sh
+++ /dev/null
-;;; -*-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:
-
-;;; make
-
-;;; Code:
-
-(define-module (guix make)
- #:use-module (ice-9 curried-definitions)
- #:use-module (ice-9 format)
- #:use-module (ice-9 optargs)
- #:use-module (ice-9 popen)
- #:use-module (ice-9 pretty-print)
- #:use-module (ice-9 rdelim)
- #:use-module (ice-9 receive)
-
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
-
- #:use-module (guix records)
- #:use-module (guix shell-utils)
-
- #:export (base-name
- build
- check
- clean
- group
- install
- target-prefix?
- check-target?
- install-target?
-
- cpp.mescc
- compile.mescc
- compile.gcc
- ld
-
- bin.mescc
- bin.gcc
- snarf
- m1.as
-
- crt1.mlibc-o
- libc-gcc.mlibc-o
- libc+tcc-gcc.mlibc-o
-
- add-target
- get-target
-
- conjoin
- system**
- target-file-name
-
- method
- target
- store
- target-inputs
- method-name
- assert-gulp-pipe*
-
- PATH-search-path
-
- %MESCC
- %HEX2
- %M1
-
- %targets
- %status
-
- %version
- %prefix
- %datadir
- %docdir
- %moduledir
- %guiledir
- %godir))
-
-(define %status 0)
-(define %targets '())
-(define %store-dir ".store")
-(mkdir-p %store-dir)
-(define %command-log (open-output-file "script"))
-
-(define (base-name file-name suffix)
- (string-drop-right file-name (string-length suffix)))
-
-(define (conjoin . predicates)
- (lambda (. arguments)
- (every (cut apply <> arguments) predicates)))
-
-(define (system** . command)
- (format %command-log "~a\n" (string-join command " "))
- (unless (zero? (apply system* command))
- (format (current-error-port) "FAILED:~s\n" command)
- (exit 1)))
-
-(define (gulp-pipe* . command)
- (let* ((port (apply open-pipe* (cons OPEN_READ command)))
- (foo (set-port-encoding! port "ISO-8859-1"))
- (output (read-string port))
- (status (close-pipe port)))
- (format %command-log "~a\n" (string-join command " "))
- (values output status)))
-
-(define (assert-gulp-pipe* . command)
- (receive (output status)
- (apply gulp-pipe* command)
- (if (zero? status) (string-trim-right output #\newline)
- (error (format #f "pipe failed: ~d ~s"
- (or (status:exit-val status)
- (status:term-sig status)) command)))))
-
-(define-record-type* <method>
- method make-method
- method?
- (name method-name)
- (build method-build (default (lambda _ #t)))
- (inputs method-inputs (default (list))))
-
-(define-record-type* <target>
- target make-target
- target?
- (file-name target-file-name (default #f)) ; string
- (file-names target-file-names (default '())) ; (string)
- (hash target-hash (default #f)) ; string
- (method target-method (default method-file)) ; <method>
- (inputs target-inputs (default (list))) ; list
-
- ; For check targets
- (baseline target-baseline (default #f)) ; string: file-name
- (exit target-exit (default #f)) ; number
- (signal target-signal (default #f))) ; number
-
-(define method-file (method (name "FILE")))
-(define method-check
- (method (name "CHECK")
- (build (lambda (o t)
- (let* ((inputs (target-inputs t))
- (file-name (target-file-name (build (car inputs))))
- (run file-name)
- (baseline (target-baseline t))
- (exit (target-exit t))
- (signal (target-signal t))
- (log (string-append file-name "-check.log")))
- (format (current-error-port) " CHECK\t~a" (basename file-name))
- (receive (output result)
- ;; FIXME: quiet MES tests are not fun
- (if (string-prefix? "tests/" run) (values #f (system* run "arg1" "arg2" "arg3" "arg4" "arg5"))
- (gulp-pipe* run "arg1" "arg2" "arg3" "arg4" "arg5"))
- (if (file-exists? log) (delete-file log))
- (if (or baseline (and output (not (string-null? output)))) (with-output-to-file log (lambda _ (display output))))
- (if baseline (set! result (system* "diff" "-bu" baseline log)))
- (let ((status (if (string? result) 0
- (or (status:term-sig result) (status:exit-val result)))))
- (if (file-exists? log) (store #:add-file log))
- (format (current-error-port) "\t[~a]\n"
- (if (or (and signal (= status signal))
- (and exit (= status exit))) "OK"
- (begin (set! %status 1) "FAIL"))))))))))
-
-(define %version (or (getenv "VERSION") "git"))
-(define %prefix (or (getenv "PREFIX") ""))
-(define %datadir "share/mes")
-(define %docdir "share/doc/mes")
-(define %moduledir (string-append %datadir "/module"))
-(define %guiledir (string-append "share/guile/site/" (effective-version)))
-(define %godir (string-append "lib/guile/" (effective-version) "/site-ccache"))
-
-(define* (method-cp #:key substitutes)
- (method (name "INSTALL")
- (build (lambda (o t)
- (let ((file-name (target-file-name t)))
- (mkdir-p (dirname file-name))
- (format (current-error-port) " INSTALL\t~a\n" file-name)
- (copy-file ((compose target-file-name car target-inputs) t) file-name)
- (if substitutes
- (begin
- (substitute* file-name
- (("module/") (string-append %prefix "/" %moduledir "/"))
- (("@DATADIR@") (string-append %prefix "/" %datadir "/"))
- (("@DOCDIR@") (string-append %prefix "/" %docdir "/"))
- (("@GODIR@") (string-append %prefix "/" %godir "/"))
- (("@GUILEDIR@") (string-append %prefix "/" %guiledir "/"))
- (("@MODULEDIR@") (string-append %prefix "/" %moduledir "/"))
- (("@PREFIX@") (string-append %prefix "/"))
- (("@VERSION@") %version)))))))))
-
-(define (hash-target o)
- (if (find (negate identity) (target-inputs o))
- (format (current-error-port) "invalid inputs[~s]: ~s\n" (target-file-name o) (target-inputs o)))
- (let ((inputs (target-inputs o)))
- (if (null? inputs) (or (target-hash o) (target-hash (store #:add o)))
- (let ((input-shas (map hash-target inputs)))
- (and (every identity input-shas)
- (let ((method (target-method o)))
- (string-hash (format #f "~s" (cons* (target-file-name o)
- (method-build method)
- (map target-hash (method-inputs method))
- input-shas)))))))))
-
-(define (string-hash o)
- (number->string (hash o (expt 2 31))))
-
-(define (file-hash o)
- (string-hash (with-input-from-file o read-string)))
-
-(define (store-file-name o)
- (string-append %store-dir "/" (if (string? o) o
- (target-hash o))))
-
-(define (link-or-cp existing-file new-file)
- (catch #t
- (lambda _ (link existing-file new-file))
- (lambda _ (copy-file existing-file new-file))))
-
-(define (assert-link existing-file new-file)
- (if (not (file-exists? new-file)) (link-or-cp existing-file new-file)))
-
-(define store
- (let ((*store* '()))
- (define (prune? o)
- (let ((t (cdr o)))
- (pair? (target-inputs t))))
- (define ((file-name? file-name) o)
- (let ((t (cdr o)))
- (equal? (target-file-name t) (target-file-name file-name))))
- (lambda* (#:key add add-file delete get key print prune)
- (cond ((and add key) (let ((value (target (inherit add) (hash key))))
- (set! *store* (assoc-set! (filter (negate (file-name? add)) *store*) key value))
- (let ((file-name (target-file-name value)))
- (if (and file-name (file-exists? file-name))
- (assert-link file-name (store-file-name value))))
- value))
- (add (let ((key (if (null? (target-inputs add)) (file-hash (target-file-name add))
- (hash-target add))))
- (if (not key) (error "store: no hash for:" add))
- (store #:add add #:key key)))
- (add-file
- (or (and=> (find (lambda (t) (equal? (target-file-name t) add-file)) (map cdr *store*))
- (compose (cut store #:get <>) target-hash))
- (and (file-exists? add-file)
- (store #:add (target (file-name add-file))))
- (error (format #f "store add-file: no such file: ~s\n" add-file))))
- ((and get key)
- (or (assoc-ref *store* key)
- (let ((store-file (store-file-name key))
- (file-name (target-file-name get)))
- (and (file-exists? store-file)
- (if (file-exists? file-name) (delete-file file-name))
- (link-or-cp store-file file-name)
- (store #:add get #:key key)))))
- (get (assoc-ref *store* get))
- (delete (and (assoc-ref *store* delete)
- (set! *store* (filter (lambda (e) (not (equal? (car e) delete))) *store*))))
- (print (pretty-print (map (lambda (e) (cons (target-file-name (cdr e)) (car e))) *store*)))
- ((eq? prune 'file-system)
- (set! *store* (filter prune? *store*)))
- (else (error "store: dunno"))))))
-
-(define (build o)
- (let ((hash (hash-target o)))
- (or (and hash (store #:get o #:key hash))
- (begin
- ;;(format (current-error-port) "must rebuild hash=~s\n" hash)
- (for-each build (target-inputs o))
- (let ((method (target-method o)))
- ((method-build method) method o))
- (store #:add o #:key hash)))))
-
-(define* (check name #:key baseline (exit 0) (signal #f) (dependencies '()))
- (target (file-name (string-append "check-" name))
- (method method-check)
- (inputs (cons (get-target name) dependencies))
- (baseline baseline)
- (exit exit)
- (signal signal)))
-
-(define* (install name #:key (dir (dirname name)) (installed-name (basename name)) (prefix %prefix) substitutes (dependencies '()))
- (target (file-name (string-append prefix "/" dir "/" installed-name))
- (method (method-cp #:substitutes substitutes))
- (inputs (cons (or (get-target name)
- (store #:add-file name)) dependencies))))
-
-(define* (group name #:key (dependencies '()))
- (target (file-name name)
- (inputs (map get-target dependencies))))
-
-(define (target->input-files o)
- (let ((inputs (target-inputs o)))
- (if (null? inputs) '()
- (append (cons (target-file-name o) (target-file-names o)) (append-map target->input-files inputs)))))
-
-(define* (clean #:optional targets)
- (for-each
- delete-file
- (filter file-exists? (delete-duplicates (append-map (cut target->input-files <>) (or targets %targets))))))
-
-(define (tree o)
- (let ((inputs (target-inputs o)))
- (if (null? inputs) o
- (cons o (append (map tree inputs) (map tree (method-inputs (target-method o))))))))
-
-
-(define (verbose fmt . o)
- ;;(apply format (cons* (current-error-port) fmt o))
- #t
- )
-
-(define* (PATH-search-path name #:key (default name))
- (or (search-path (string-split (getenv "PATH") #\:) name)
- (and (format (current-error-port) "warning: not found: ~a\n" name)
- default)))
-
-(define %CC (or (getenv "CC") (PATH-search-path "gcc")))
-(define %CC32 (or (getenv "CC32")
- (PATH-search-path "i686-unknown-linux-gnu-gcc" #:default #f)
- (and (format (current-error-port) "warning: CC32 not found, trying gcc -m32")
- %CC)))
-
-(define %C-FLAGS
- '("--std=gnu99"
- "-O0"
- "-g"
- "-D"
- "POSIX=1"
- "-I" "src"
- "-I" "lib"
- "-I" "include"
- "--include=lib/libc-gcc.c"))
-
-(define %C32-FLAGS
- '("--std=gnu99"
- "-O0"
- "-fno-stack-protector"
- "-g"
- "-m32"
- "-I" "src"
- "-I" "lib"
- "-I" "include"))
-
-(define* (CC.gcc #:key (libc #t) (cc (if (eq? libc #t) %CC %CC32)) (c-flags (if (eq? libc #t) %C-FLAGS %C32-FLAGS)) (defines '()) (includes '()))
- (method (name "CC.gcc")
- (build (lambda (o t)
- (let* ((input-files (map target-file-name (target-inputs t)))
- (command `(,cc
- "-c"
- ,@(append-map (cut list "-D" <>) defines)
- ,@(append-map (cut list "-I" <>) includes)
- ,@(if (eq? libc #t) '() '("-nostdinc" "-fno-builtin"))
- ,@c-flags
- "-o" ,(target-file-name t)
- ,@(filter (cut string-suffix? ".c" <>) input-files))))
- (format (current-error-port) " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
- (apply system** command))))))
-
-(define* (CPP.mescc #:key (cc %MESCC) (defines '()) (includes '()))
- (method (name "CPP.mescc")
- (build (lambda (o t)
- (let ((input-files (map target-file-name (target-inputs t))))
- (format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
- (apply system**
- `(,cc
- "-E"
- ,@(append-map (cut list "-D" <>) defines)
- ,@(append-map (cut list "-I" <>) includes)
- "-o" ,(target-file-name t)
- ,@input-files)))))))
-
-(define %MESCC "scripts/mescc")
-(define* (CC.mescc #:key (cc %MESCC))
- (method (name "CC.mescc")
- (build (lambda (o t)
- (let ((input-files (map target-file-name (target-inputs t))))
- (format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
- (setenv "MES" "guile")
- (apply system**
- `("scripts/mescc" "-c"
- "-o" ,(target-file-name t)
- ,@input-files))
- (unsetenv "MES"))))
- (inputs (list (store #:add-file "guile/language/c99/info.go")
- (store #:add-file "guile/language/c99/compiler.go")
- (store #:add-file "guile/mes/as-i386.go")
- (store #:add-file "guile/mes/as.go")
- (store #:add-file "guile/mes/elf.go")
- (store #:add-file "guile/mes/bytevectors.go")
- (store #:add-file "guile/mes/M1.go")
- (store #:add-file "guile/mes/guile.go")))))
-
-(define %M1 (or (PATH-search-path "M1" #:default #f)
- (PATH-search-path "M0" #:default #f) ; M1 is in unreleased mescc-tools 0.2
- (and (format (current-error-port) "error: no macro assembler found, please install mescc-tools\n")
- (exit 1))))
-(define %M0-FLAGS
- '("--LittleEndian"))
-(define %M1-FLAGS
- '("--LittleEndian"
- "--Architecture=1"))
-(if (equal? (basename %M1) "M0")
- (set! %M1-FLAGS %M0-FLAGS))
-
-(define* (M1.as #:key (m1 %M1) (m1-flags %M1-FLAGS))
- (method (name "M1")
- (build (lambda (o t)
- (let* ((input-files (map target-file-name (target-inputs t)))
- (input-files (filter (lambda (f) (string-suffix? "M1" f))
- input-files)))
- (format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
- (with-output-to-file (target-file-name t)
- (lambda _
- (display
- (apply assert-gulp-pipe*
- `(,m1
- "-f"
- "stage0/x86.M1"
- ,@(append-map (cut list "-f" <>) input-files)
- ,@m1-flags)))
- (newline))))))
- (inputs (list (store #:add-file "stage0/x86.M1")))))
-
-(define* (LINK.gcc #:key (cc %CC) (libc #t) (c-flags (if (eq? libc #t) %C-FLAGS %C32-FLAGS)) (crt1 #f))
- (method (name "LINK.gcc")
- (build (lambda (o t)
- (let* ((input-files (map target-file-name (target-inputs t)))
- (command `(,cc
- ,@c-flags
- ,@(if (eq? libc #t) '() '("-nostdlib"))
- "-o"
- ,(target-file-name t)
- ,@(if crt1 (list (target-file-name crt1))'())
- ,@input-files
- ,@(cond ((eq? libc #t) '())
- (libc (list (target-file-name libc)))
- (else '())))))
- (format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
- (apply system** command))))))
-
-(define SNARF "build-aux/mes-snarf.scm")
-(define (SNARF.mes mes?)
- (method (name "SNARF.mes")
- (build (lambda (o t)
- (let* ((input-files (map target-file-name (target-inputs t)))
- (command `(,SNARF
- ,@(if mes? '("--mes") '())
- ,@input-files)))
- (format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
- (apply system** command))))))
-
-(define* (cpp.mescc input-file-name #:key (cc %MESCC) (defines '()) (includes '()) (dependencies '()))
- (let* ((c-target (target (file-name input-file-name)))
- (base-name (base-name input-file-name ".c"))
- (suffix ".E")
- (target-file-name (string-append base-name suffix)))
- (target (file-name target-file-name)
- (inputs (cons c-target dependencies))
- (method (CPP.mescc #:cc cc #:defines defines #:includes includes)))))
-
-(define* (compile.gcc input-file-name #:key (libc #t) (cc (if (eq? libc #t) %CC %CC32)) (defines '()) (includes '()) (dependencies '()))
- (let* ((base-name (base-name input-file-name ".c"))
- (cross (if (eq? libc #t) "" "mlibc-"))
- (suffix (string-append "." cross "o"))
- (target-file-name (string-append base-name suffix))
- (c-target (target (file-name input-file-name))))
- (target (file-name target-file-name)
- (inputs (cons c-target dependencies))
- (method (CC.gcc #:cc cc #:libc libc #:defines defines #:includes includes)))))
-
-(define* (compile.mescc input-file-name #:key (cc %MESCC) (defines '()) (includes '()) (dependencies '()))
- (let* ((base-name (base-name input-file-name ".c"))
- (suffix ".M1")
- (target-file-name (string-append base-name suffix))
- (E-target (cpp.mescc input-file-name #:cc cc #:defines defines #:includes includes #:dependencies dependencies)))
- (target (file-name target-file-name)
- (inputs `(,E-target))
- (method (CC.mescc #:cc cc)))))
-
-(define* (m1.as input-file-name #:key (cc %MESCC) (m1 %M1) (defines '()) (includes '()) (dependencies '()))
- (let* ((base-name (base-name input-file-name ".c"))
- ;;(foo (format (current-error-port) "m1.as[~s .m1] base=~s\n" input-file-name base-name))
- (suffix ".hex2")
- (target-file-name (string-append base-name suffix))
- (m1-target (compile.mescc input-file-name #:cc cc #:defines defines #:includes includes #:dependencies dependencies)))
- (target (file-name target-file-name)
- (inputs `(,m1-target))
- (method (M1.as #:m1 m1)))))
-
-(define* (bin.gcc input-file-name #:key (libc #t) (crt1 (if (eq? libc #t) #f crt1.mlibc-o)) (cc (if (eq? libc #t) %CC %CC32)) (dependencies '()) (defines '()) (includes '()))
- (and cc
- (let* ((base-name (base-name input-file-name ".c"))
- (suffix (if (eq? libc #t) ".gcc" ".mlibc-gcc"))
- (target-file-name (string-append base-name suffix))
- (o-target (compile.gcc input-file-name #:cc cc #:libc libc #:defines defines #:includes includes #:dependencies dependencies)))
- (target (file-name target-file-name)
- (inputs (list o-target))
- (method (LINK.gcc #:cc cc #:libc libc #:crt1 crt1))))))
-
-(define* (snarf input-file-name #:key (dependencies '()) (mes? #t))
- (let* ((base-name (base-name input-file-name ".c"))
- (suffixes '(".h" ".i" ".environment.i" ".symbol-names.i" ".symbols.i" ".symbols.h"))
- (suffixes (if mes? (map (cut string-append ".mes" <>) suffixes) suffixes))
- (target-file-names (map (cut string-append base-name <>) suffixes))
- (snarf-target (target (file-name input-file-name))))
- (target (file-name (car target-file-names))
- (file-names (cdr target-file-names))
- (inputs (cons snarf-target dependencies))
- ;;(inputs (list snarf-target))
- (method (SNARF.mes mes?)))))
-
-(define ((target-prefix? prefix) o)
- (string-prefix? prefix (target-file-name o)))
-
-(define (check-target? o)
- (and o ((target-prefix? "check-") o)))
-
-(define (install-target? o)
- (and o ((target-prefix? (or (getenv "PREFIX") "/")) o)))
-
-(define (add-target o)
- (and o (set! %targets (append %targets (list o))))
- o)
-(define (get-target o)
- (if (target? o) o
- (find (lambda (t) (equal? (target-file-name t) o)) %targets)))
-
-(define crt1.mlibc-o (compile.gcc "lib/crt1.c" #:libc #f))
-(define libc-gcc.mlibc-o (compile.gcc "lib/libc-gcc.c" #:libc #f))
-(define libc+tcc-gcc.mlibc-o (compile.gcc "lib/libc+tcc-gcc.c" #:libc #f))
+++ /dev/null
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 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/>.
-
-(define-module (guix records)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-26)
- #:use-module (ice-9 match)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 rdelim)
- #:export (define-record-type*
- alist->record
- object->fields
- recutils->alist))
-
-;;; Commentary:
-;;;
-;;; Utilities for dealing with Scheme records.
-;;;
-;;; Code:
-
-(define-syntax record-error
- (syntax-rules ()
- "Report a syntactic error in use of CONSTRUCTOR."
- ((_ constructor form fmt args ...)
- (syntax-violation constructor
- (format #f fmt args ...)
- form))))
-
-(define (report-invalid-field-specifier name bindings)
- "Report the first invalid binding among BINDINGS."
- (let loop ((bindings bindings))
- (syntax-case bindings ()
- (((field value) rest ...) ;good
- (loop #'(rest ...)))
- ((weird _ ...) ;weird!
- (syntax-violation name "invalid field specifier" #'weird)))))
-
-(define-syntax make-syntactic-constructor
- (syntax-rules ()
- "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
-expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
-FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
-fields, and DELAYED is the list of identifiers of delayed fields."
- ((_ type name ctor (expected ...)
- #:thunked thunked
- #:delayed delayed
- #:innate innate
- #:defaults defaults)
- (define-syntax name
- (lambda (s)
- (define (record-inheritance orig-record field+value)
- ;; Produce code that returns a record identical to ORIG-RECORD,
- ;; except that values for the FIELD+VALUE alist prevail.
- (define (field-inherited-value f)
- (and=> (find (lambda (x)
- (eq? f (car (syntax->datum x))))
- field+value)
- car))
-
- ;; Make sure there are no unknown field names.
- (let* ((fields (map (compose car syntax->datum) field+value))
- (unexpected (lset-difference eq? fields '(expected ...))))
- (when (pair? unexpected)
- (record-error 'name s "extraneous field initializers ~a"
- unexpected)))
-
- #`(make-struct/no-tail type
- #,@(map (lambda (field index)
- (or (field-inherited-value field)
- (if (innate-field? field)
- (wrap-field-value
- field (field-default-value field))
- #`(struct-ref #,orig-record
- #,index))))
- '(expected ...)
- (iota (length '(expected ...))))))
-
- (define (thunked-field? f)
- (memq (syntax->datum f) 'thunked))
-
- (define (delayed-field? f)
- (memq (syntax->datum f) 'delayed))
-
- (define (innate-field? f)
- (memq (syntax->datum f) 'innate))
-
- (define (wrap-field-value f value)
- (cond ((thunked-field? f)
- #`(lambda () #,value))
- ((delayed-field? f)
- #`(delay #,value))
- (else value)))
-
- (define default-values
- ;; List of symbol/value tuples.
- (map (match-lambda
- ((f v)
- (list (syntax->datum f) v)))
- #'defaults))
-
- (define (field-default-value f)
- (car (assoc-ref default-values (syntax->datum f))))
-
- (define (field-bindings field+value)
- ;; Return field to value bindings, for use in 'let*' below.
- (map (lambda (field+value)
- (syntax-case field+value ()
- ((field value)
- #`(field
- #,(wrap-field-value #'field #'value)))))
- field+value))
-
- (syntax-case s (inherit expected ...)
- ((_ (inherit orig-record) (field value) (... ...))
- #`(let* #,(field-bindings #'((field value) (... ...)))
- #,(record-inheritance #'orig-record
- #'((field value) (... ...)))))
- ((_ (field value) (... ...))
- (let ((fields (map syntax->datum #'(field (... ...)))))
- (define (field-value f)
- (or (find (lambda (x)
- (eq? f (syntax->datum x)))
- #'(field (... ...)))
- (wrap-field-value f (field-default-value f))))
-
- (let ((fields (append fields (map car default-values))))
- (cond ((lset= eq? fields '(expected ...))
- #`(let* #,(field-bindings
- #'((field value) (... ...)))
- (ctor #,@(map field-value '(expected ...)))))
- ((pair? (lset-difference eq? fields
- '(expected ...)))
- (record-error 'name s
- "extraneous field initializers ~a"
- (lset-difference eq? fields
- '(expected ...))))
- (else
- (record-error 'name s
- "missing field initializers ~a"
- (lset-difference eq?
- '(expected ...)
- fields)))))))
- ((_ bindings (... ...))
- ;; One of BINDINGS doesn't match the (field value) pattern.
- ;; Report precisely which one is faulty, instead of letting the
- ;; "source expression failed to match any pattern" error.
- (report-invalid-field-specifier 'name
- #'(bindings (... ...))))))))))
-
-(define-syntax-rule (define-field-property-predicate predicate property)
- "Define PREDICATE as a procedure that takes a syntax object and, when passed
-a field specification, returns the field name if it has the given PROPERTY."
- (define (predicate s)
- (syntax-case s (property)
- ((field (property values (... ...)) _ (... ...))
- #'field)
- ((field _ properties (... ...))
- (predicate #'(field properties (... ...))))
- (_ #f))))
-
-(define-syntax define-record-type*
- (lambda (s)
- "Define the given record type such that an additional \"syntactic
-constructor\" is defined, which allows instances to be constructed with named
-field initializers, à la SRFI-35, as well as default values. An example use
-may look like this:
-
- (define-record-type* <thing> thing make-thing
- thing?
- (name thing-name (default \"chbouib\"))
- (port thing-port
- (default (current-output-port)) (thunked))
- (loc thing-location (innate) (default (current-source-location))))
-
-This example defines a macro 'thing' that can be used to instantiate records
-of this type:
-
- (thing
- (name \"foo\")
- (port (current-error-port)))
-
-The value of 'name' or 'port' could as well be omitted, in which case the
-default value specified in the 'define-record-type*' form is used:
-
- (thing)
-
-The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
-actually compute the field's value in the current dynamic extent, which is
-useful when referring to fluids in a field's value.
-
-A field can also be marked as \"delayed\" instead of \"thunked\", in which
-case its value is effectively wrapped in a (delay …) form.
-
-It is possible to copy an object 'x' created with 'thing' like this:
-
- (thing (inherit x) (name \"bar\"))
-
-This expression returns a new object equal to 'x' except for its 'name'
-field and its 'loc' field---the latter is marked as \"innate\", so it is not
-inherited."
-
- (define (field-default-value s)
- (syntax-case s (default)
- ((field (default val) _ ...)
- (list #'field #'val))
- ((field _ properties ...)
- (field-default-value #'(field properties ...)))
- (_ #f)))
-
- (define-field-property-predicate delayed-field? delayed)
- (define-field-property-predicate thunked-field? thunked)
- (define-field-property-predicate innate-field? innate)
-
- (define (wrapped-field? s)
- (or (thunked-field? s) (delayed-field? s)))
-
- (define (wrapped-field-accessor-name field)
- ;; Return the name (an unhygienic syntax object) of the "real"
- ;; getter for field, which is assumed to be a wrapped field.
- (syntax-case field ()
- ((field get properties ...)
- (let* ((getter (syntax->datum #'get))
- (real-getter (symbol-append '% getter '-real)))
- (datum->syntax #'get real-getter)))))
-
- (define (field-spec->srfi-9 field)
- ;; Convert a field spec of our style to a SRFI-9 field spec of the
- ;; form (field get).
- (syntax-case field ()
- ((name get properties ...)
- #`(name
- #,(if (wrapped-field? field)
- (wrapped-field-accessor-name field)
- #'get)))))
-
- (define (thunked-field-accessor-definition field)
- ;; Return the real accessor for FIELD, which is assumed to be a
- ;; thunked field.
- (syntax-case field ()
- ((name get _ ...)
- (with-syntax ((real-get (wrapped-field-accessor-name field)))
- #'(define-inlinable (get x)
- ;; The real value of that field is a thunk, so call it.
- ((real-get x)))))))
-
- (define (delayed-field-accessor-definition field)
- ;; Return the real accessor for FIELD, which is assumed to be a
- ;; delayed field.
- (syntax-case field ()
- ((name get _ ...)
- (with-syntax ((real-get (wrapped-field-accessor-name field)))
- #'(define-inlinable (get x)
- ;; The real value of that field is a promise, so force it.
- (force (real-get x)))))))
-
- (syntax-case s ()
- ((_ type syntactic-ctor ctor pred
- (field get properties ...) ...)
- (let* ((field-spec #'((field get properties ...) ...))
- (thunked (filter-map thunked-field? field-spec))
- (delayed (filter-map delayed-field? field-spec))
- (innate (filter-map innate-field? field-spec))
- (defaults (filter-map field-default-value
- #'((field properties ...) ...))))
- (with-syntax (((field-spec* ...)
- (map field-spec->srfi-9 field-spec))
- ((thunked-field-accessor ...)
- (filter-map (lambda (field)
- (and (thunked-field? field)
- (thunked-field-accessor-definition
- field)))
- field-spec))
- ((delayed-field-accessor ...)
- (filter-map (lambda (field)
- (and (delayed-field? field)
- (delayed-field-accessor-definition
- field)))
- field-spec)))
- #`(begin
- (define-record-type type
- (ctor field ...)
- pred
- field-spec* ...)
- thunked-field-accessor ...
- delayed-field-accessor ...
- (make-syntactic-constructor type syntactic-ctor ctor
- (field ...)
- #:thunked #,thunked
- #:delayed #,delayed
- #:innate #,innate
- #:defaults #,defaults))))))))
-
-(define* (alist->record alist make keys
- #:optional (multiple-value-keys '()))
- "Apply MAKE to the values associated with KEYS in ALIST. Items in KEYS that
-are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
-times in ALIST, and thus their value is a list."
- (let ((args (map (lambda (key)
- (if (member key multiple-value-keys)
- (filter-map (match-lambda
- ((k . v)
- (and (equal? k key) v)))
- alist)
- (assoc-ref alist key)))
- keys)))
- (apply make args)))
-
-(define (object->fields object fields port)
- "Write OBJECT (typically a record) as a series of recutils-style fields to
-PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
- (let loop ((fields fields))
- (match fields
- (()
- object)
- (((field . get) rest ...)
- (format port "~a: ~a~%" field (get object))
- (loop rest)))))
-
-(define %recutils-field-charset
- ;; Valid characters starting a recutils field.
- ;; info "(recutils) Fields"
- (char-set-union char-set:upper-case
- char-set:lower-case
- (char-set #\%)))
-
-(define (recutils->alist port)
- "Read a recutils-style record from PORT and return it as a list of key/value
-pairs. Stop upon an empty line (after consuming it) or EOF."
- (let loop ((line (read-line port))
- (result '()))
- (cond ((eof-object? line)
- (reverse result))
- ((string-null? line)
- (if (null? result)
- (loop (read-line port) result) ; leading space: ignore it
- (reverse result))) ; end-of-record marker
- (else
- ;; Now check the first character of LINE, since that's what the
- ;; recutils manual says is enough.
- (let ((first (string-ref line 0)))
- (cond
- ((char-set-contains? %recutils-field-charset first)
- (let* ((colon (string-index line #\:))
- (field (string-take line colon))
- (value (string-trim (string-drop line (+ 1 colon)))))
- (loop (read-line port)
- (alist-cons field value result))))
- ((eqv? first #\#) ;info "(recutils) Comments"
- (loop (read-line port) result))
- ((eqv? first #\+) ;info "(recutils) Fields"
- (let ((new-line (if (string-prefix? "+ " line)
- (string-drop line 2)
- (string-drop line 1))))
- (match result
- (((field . value) rest ...)
- (loop (read-line port)
- `((,field . ,(string-append value "\n" new-line))
- ,@rest))))))
- (else
- (error "unmatched line" line))))))))
-
-;;; records.scm ends here
+++ /dev/null
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
-;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2015 Mark H Weaver <mhw@netris.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/>.
-
-(define-module (guix shell-utils)
- #:use-module (ice-9 match)
- #:use-module (ice-9 rdelim)
- #:use-module (ice-9 regex)
- #:use-module (srfi srfi-1)
- #:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
- #:export (dump-port
- mkdir-p
- with-directory-excursion
- substitute
- substitute*))
-
-;;;
-;;; Directories.
-;;;
-
-(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-syntax-rule (with-directory-excursion dir body ...)
- "Run BODY with DIR as the process's current directory."
- (let ((init (getcwd)))
- (dynamic-wind
- (lambda ()
- (chdir dir))
- (lambda ()
- body ...)
- (lambda ()
- (chdir init)))))
-
-(define* (dump-port in out
- #:key (buffer-size 16384)
- (progress (lambda (t k) (k))))
- "Read as much data as possible from IN and write it to OUT, using chunks of
-BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
-transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
-transferred and the continuation of the transfer as a thunk."
- (define buffer
- (make-bytevector buffer-size))
-
- (define (loop total bytes)
- (or (eof-object? bytes)
- (let ((total (+ total bytes)))
- (put-bytevector out buffer 0 bytes)
- (progress total
- (lambda ()
- (loop total
- (get-bytevector-n! in buffer 0 buffer-size)))))))
-
- ;; Make sure PROGRESS is called when we start so that it can measure
- ;; throughput.
- (progress 0
- (lambda ()
- (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
-
-\f
-;;;
-;;; Text substitution (aka. sed).
-;;;
-
-(define (with-atomic-file-replacement file proc)
- "Call PROC with two arguments: an input port for FILE, and an output
-port for the file that is going to replace FILE. Upon success, FILE is
-atomically replaced by what has been written to the output port, and
-PROC's result is returned."
- (let* ((template (string-append file ".XXXXXX"))
- (out (mkstemp! template))
- (mode (stat:mode (stat file))))
- (with-throw-handler #t
- (lambda ()
- (call-with-input-file file
- (lambda (in)
- (let ((result (proc in out)))
- (close out)
- (chmod template mode)
- (rename-file template file)
- result))))
- (lambda (key . args)
- (false-if-exception (delete-file template))))))
-
-(define (substitute file pattern+procs)
- "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each
-line of FILE, and for each PATTERN that it matches, call the corresponding
-PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
-a substitution of the original line. Be careful about using '$' to match the
-end of a line; by itself it won't match the terminating newline of a line."
- (let ((rx+proc (map (match-lambda
- (((? regexp? pattern) . proc)
- (cons pattern proc))
- ((pattern . proc)
- (cons (make-regexp pattern regexp/extended)
- proc)))
- pattern+procs)))
- (with-atomic-file-replacement file
- (lambda (in out)
- (let loop ((line (read-line in 'concat)))
- (if (eof-object? line)
- #t
- (let ((line (fold (lambda (r+p line)
- (match r+p
- ((regexp . proc)
- (match (list-matches regexp line)
- ((and m+ (_ _ ...))
- (proc line m+))
- (_ line)))))
- line
- rx+proc)))
- (display line out)
- (loop (read-line in 'concat)))))))))
-
-
-(define-syntax let-matches
- ;; Helper macro for `substitute*'.
- (syntax-rules (_)
- ((let-matches index match (_ vars ...) body ...)
- (let-matches (+ 1 index) match (vars ...)
- body ...))
- ((let-matches index match (var vars ...) body ...)
- (let ((var (match:substring match index)))
- (let-matches (+ 1 index) match (vars ...)
- body ...)))
- ((let-matches index match () body ...)
- (begin body ...))))
-
-(define-syntax substitute*
- (syntax-rules ()
- "Substitute REGEXP in FILE by the string returned by BODY. BODY is
-evaluated with each MATCH-VAR bound to the corresponding positional regexp
-sub-expression. For example:
-
- (substitute* file
- ((\"hello\")
- \"good morning\\n\")
- ((\"foo([a-z]+)bar(.*)$\" all letters end)
- (string-append \"baz\" letter end)))
-
-Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
-morning\". Anytime a line of FILE matches the second regexp, ALL is bound to
-the complete match, LETTERS is bound to the first sub-expression, and END is
-bound to the last one.
-
-When one of the MATCH-VAR is `_', no variable is bound to the corresponding
-match substring.
-
-Alternatively, FILE may be a list of file names, in which case they are
-all subject to the substitutions.
-
-Be careful about using '$' to match the end of a line; by itself it won't
-match the terminating newline of a line."
- ((substitute* file ((regexp match-var ...) body ...) ...)
- (let ()
- (define (substitute-one-file file-name)
- (substitute
- file-name
- (list (cons regexp
- (lambda (l m+)
- ;; Iterate over matches M+ and return the
- ;; modified line based on L.
- (let loop ((m* m+) ; matches
- (o 0) ; offset in L
- (r '())) ; result
- (match m*
- (()
- (let ((r (cons (substring l o) r)))
- (string-concatenate-reverse r)))
- ((m . rest)
- (let-matches 0 m (match-var ...)
- (loop rest
- (match:end m)
- (cons*
- (begin body ...)
- (substring l o (match:start m))
- r))))))))
- ...)))
-
- (match file
- ((files (... ...))
- (for-each substitute-one-file files))
- ((? string? f)
- (substitute-one-file f)))))))
-
set -e
-PREFIX=${PREFIX-usr}
+export PREFIX=${PREFIX-/usr/local}
MES_PREFIX=${MES_PREFIX-$PREFIX/share/mes}
MES_SEED=${MES_SEED-../mes-seed}
TINYCC_SEED=${TINYCC_SEED-../tinycc-seed}
mkdir -p $PREFIX/lib
mkdir -p $MES_PREFIX/lib
-cp $MES_SEED/crt1.M1 $MES_PREFIX/lib/crt1.M1
-cp $MES_SEED/libc-mes.M1 $MES_PREFIX/lib/libc-mes.M1
-cp $MES_SEED/libc+tcc-mes.M1 $MES_PREFIX/lib/libc+tcc-mes.M1
-
-cp crt1.hex2 $MES_PREFIX/lib/crt1.hex2
-cp libc-mes.hex2 $MES_PREFIX/lib/libc-mes.hex2
-cp libc+tcc-mes.hex2 $MES_PREFIX/lib/libc+tcc-mes.hex2
-
cp scripts/mescc $PREFIX/bin/mescc
-sed -e "s,@PREFIX@,$MES_PREFIX,g" \
- scripts/mescc > $PREFIX/bin/mescc
mkdir -p $MES_PREFIX
tar -cf- doc guile include lib module scaffold stage0 | tar -xf- -C $MES_PREFIX
+
+GUILE_EFFECTIVE_VERSION=${GUILE_EFFECTIVE_VERSION-2.2}
+DATADIR=${MODULEDIR-$PREFIX/share/mes}
+DOCDIR=${MODULEDIR-$PREFIX/share/doc/mes}
+MODULEDIR=${MODULEDIR-$DATADIR/module}
+GUILEDIR=${MODULEDIR-$PREFIX/share/guile/site/$GUILE_EFFECTIVE_VERSION}
+GODIR=${GODIR-$PREFIX/lib/guile/$GUILE_EFFECTIVE_VERSION/site-ccache}
+DOCDIR=${MODULEDIR-$PREFIX/share/doc/mes}
+
+chmod +w $PREFIX/bin/mescc
+sed \
+ -e "s,module/,$MODULEDIR/," \
+ -e "s,@DATADIR@,$DATADIR,g" \
+ -e "s,@DOCDIR@,$DOCDIR,g" \
+ -e "s,@GODIR@,$GODIR,g" \
+ -e "s,@GUILEDIR@,$GUILEDIR,g" \
+ -e "s,@MODULEDIR@,$MODULEDIR,g" \
+ -e "s,@PREFIX@,$PREFIX,g" \
+ -e "s,@VERSION@,$VERSION,g" \
+ scripts/mescc > $PREFIX/bin/mescc
+chmod +w $MODULEDIR/mes/boot-0.scm
+sed \
+ -e "s,module/,$MODULEDIR/," \
+ -e "s,@DATADIR@,$DATADIR,g" \
+ -e "s,@DOCDIR@,$DOCDIR,g" \
+ -e "s,@GODIR@,$GODIR,g" \
+ -e "s,@GUILEDIR@,$GUILEDIR,g" \
+ -e "s,@MODULEDIR@,$MODULEDIR,g" \
+ -e "s,@PREFIX@,$PREFIX,g" \
+ -e "s,@VERSION@,$VERSION,g" \
+ module/mes/boot-0.scm > $MODULEDIR/mes/boot-0.scm
+++ /dev/null
-#! /bin/sh
-# -*- scheme -*-
-exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$@"}
-!#
-
-;;; 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/>.
-
-(use-modules (srfi srfi-26)
- (guix shell-utils))
-
-;; FIXME: .go dependencies
-;; workaround: always update .go before calculating hashes
-;;(use-modules ((mes make) #:select (sytem**)))
-(define %scm-files
- '("guix/make.scm"
- "guix/records.scm"
- "guix/shell-utils.scm"
- "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/M1.scm"))
-(define %go-files (map (compose (cut string-append <> ".go") (cut string-drop-right <> 4)) %scm-files))
-(setenv "srcdir" ".")
-(setenv "host" %host-type)
-(with-directory-excursion "guile"
- (apply system* `("guile"
- "--no-auto-compile"
- "-L" "."
- "-C" "."
- "-s"
- "../build-aux/compile-all.scm"
- ,@%scm-files)))
-
-(use-modules (srfi srfi-1)
- (ice-9 curried-definitions)
- (ice-9 match)
- (guix make))
-
-(define crt1.hex2 (m1.as "lib/crt1.c"))
-(add-target crt1.hex2)
-
-(add-target crt1.mlibc-o)
-
-(define %HEX2-FLAGS
- '("--LittleEndian"
- "--Architecture=1"
- "--BaseAddress=0x1000000"))
-(define %HEX2 (PATH-search-path "hex2"))
-
-(define* (LINK.hex2 #:key (hex2 %HEX2) (hex2-flags %HEX2-FLAGS) (crt1 crt1.hex2) (libc libc-mes.hex2) debug?)
- (method (name "LINK.hex2")
- (build (lambda (o t)
- (let* ((input-files (map target-file-name (target-inputs t)))
- ;; FIXME: snarf inputs
- (input-files (filter (lambda (f) (and (string-suffix? "hex2" f)
- (not (member f (cdr input-files)))))
- input-files)))
- (format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
- (with-output-to-file (target-file-name t)
- (lambda _
- (set-port-encoding! (current-output-port) "ISO-8859-1")
- (display
- (apply assert-gulp-pipe*
- `(,hex2
- ,@hex2-flags
- "-f"
- ,(if (not debug?) "stage0/elf32-0header.hex2"
- "stage0/elf32-header.hex2")
- ,@(if crt1 `("-f" ,(target-file-name crt1)) '())
- ,@(if libc `("-f" ,(target-file-name libc)) '())
- ,@(append-map (cut list "-f" <>) input-files)
- "-f"
- ,(if (not debug?) "stage0/elf-0footer.hex2"
- "stage0/elf32-footer-single-main.hex2"))))))
- (chmod (target-file-name t) #o755))))
- (inputs `(,(store #:add-file "stage0/elf32-0header.hex2")
- ,@(if crt1 (target-inputs crt1) '())
- ,@(if libc (target-inputs libc) '())
- ,(store #:add-file "stage0/elf-0footer.hex2")))))
-
-(define* (bin.mescc input-file-name #:key (cc %MESCC) (hex2 %HEX2) (m1 %M1) (crt1 crt1.hex2) (libc libc-mes.hex2) (dependencies '()) (defines '()) (includes '()))
- (let* ((base-name (base-name input-file-name ".c"))
- ;;(foo (format (current-error-port) "bin[~s .c] base=~s\n" input-file-name base-name))
- (suffix (cond ((not libc) ".0-guile")
- ((eq? libc libc-mes.hex2) ".guile")
- ((eq? libc libc+tcc-mes.hex2) ".tcc-guile")
- (else ".mini-guile")))
- (target-file-name (string-append base-name suffix))
- (hex2-target (m1.as input-file-name #:m1 m1 #:cc cc #:defines defines #:includes includes #:dependencies dependencies)))
- (target (file-name target-file-name)
- (inputs `(,hex2-target
- ,@(if crt1 (list crt1) '())
- ,@(if libc (list libc) '())))
- (method (LINK.hex2 #:hex2 hex2 #:crt1 crt1 #:libc libc #:debug? (eq? libc libc-mes.hex2))))))
-
-;;(define mini-libc-mes.E (m1.as "lib/mini-libc-mes.c"))
-
-(define libc-mes.hex2 (m1.as "lib/libc-mes.c"))
-(add-target libc-mes.hex2)
-
-(define mini-libc-mes.hex2 (m1.as "lib/mini-libc-mes.c"))
-(add-target mini-libc-mes.hex2)
-
-(define libc+tcc-mes.hex2 (m1.as "lib/libc+tcc-mes.c"))
-(add-target libc+tcc-mes.hex2)
-
-(add-target (bin.mescc "stage0/exit-42.c" #:libc #f))
-(add-target (check "stage0/exit-42.0-guile" #:exit 42))
-
-(add-target (cpp.mescc "lib/mini-libc-mes.c"))
-(add-target (compile.mescc "lib/mini-libc-mes.c"))
-
-(add-target (bin.mescc "stage0/exit-42.c" #:libc mini-libc-mes.hex2))
-(add-target (check "stage0/exit-42.mini-guile" #:exit 42))
-
-(add-target (cpp.mescc "lib/libc-mes.c"))
-(add-target (compile.mescc "lib/libc-mes.c"))
-
-(add-target (bin.mescc "stage0/exit-42.c"))
-(add-target (check "stage0/exit-42.guile" #:exit 42))
-
-(define* (add-scaffold-test name #:key (exit 0) (libc libc-mes.hex2) (libc-gcc libc-gcc.mlibc-o) (includes '()))
- (add-target (bin.gcc (string-append "scaffold/tests/" name ".c") #:libc libc-gcc #:includes includes))
- (add-target (check (string-append "scaffold/tests/" name ".mlibc-gcc") #:exit exit))
-
- (add-target (bin.mescc (string-append "scaffold/tests/" name ".c") #:libc libc #:includes includes))
- (add-target (check (string-append "scaffold/tests/" name "." (cond ((not libc) "0-")
- ((eq? libc mini-libc-mes.hex2) "mini-")
- ((eq? libc libc+tcc-mes.hex2) "tcc-")
- (else "")) "guile") #:exit exit)))
-
-(add-target (compile.gcc "lib/crt1.c" #:libc #f))
-(add-target (compile.gcc "lib/libc-gcc.c" #:libc #f))
-(add-target (compile.gcc "lib/libc+tcc-gcc.c" #:libc #f))
-;;(add-target (compile.gcc "lib/libc+tcc-mes.c" #:libc #f))
-
-;;(add-scaffold-test "t" #:libc mini-libc-mes.hex2)
-(add-scaffold-test "t")
-;;(add-scaffold-test "t" #:libc libc+tcc-mes.hex2)
-
-;; tests/00: exit, functions without libc
-(add-scaffold-test "00-exit-0" #:libc #f)
-(add-scaffold-test "01-return-0" #:libc #f)
-(add-scaffold-test "02-return-1" #:libc #f #:exit 1)
-(add-scaffold-test "03-call" #:libc #f)
-(add-scaffold-test "04-call-0" #:libc #f)
-(add-scaffold-test "05-call-1" #:libc #f #:exit 1)
-(add-scaffold-test "06-call-!1" #:libc #f)
-(add-scaffold-test "07-include" #:libc #f #:includes '("scaffold/tests") #:exit 42)
-
-(add-target (group "check-scaffold-tests/0" #:dependencies (filter (target-prefix? "check-scaffold/tests/0") %targets)))
-
-;; tests/10: control without libc
-(for-each
- (cut add-scaffold-test <> #:libc #f)
- '("10-if-0"
- "11-if-1"
- "12-if-=="
- "13-if-!="
- "14-if-goto"
- "15-if-!f"
- "16-if-t"))
-
-(add-target (group "check-scaffold-tests/1" #:dependencies (filter (target-prefix? "check-scaffold/tests/1") %targets)))
-
-;; tests/20: loop without libc
-(for-each
- (cut add-scaffold-test <> #:libc #f)
- '("20-while"
- "21-char[]"
- "22-while-char[]"
- "23-pointer"))
-
-(add-target (group "check-scaffold-tests/2" #:dependencies (filter (target-prefix? "check-scaffold/tests/2") %targets)))
-
-;; tests/30: call, compare: mini-libc-mes.c
-(for-each
- (cut add-scaffold-test <> #:libc mini-libc-mes.hex2)
- '("30-strlen"
- "31-eputs"
- "32-compare"
- "33-and-or"
- "34-pre-post"
- "35-compare-char"
- "36-compare-arithmetic"
- "37-compare-assign"
- "38-compare-call"))
-
-(add-target (group "check-scaffold-tests/3" #:dependencies (filter (target-prefix? "check-scaffold/tests/3") %targets)))
-
-;; tests/40: control: mini-libc-mes.c
-(for-each
- (cut add-scaffold-test <> #:libc mini-libc-mes.hex2)
- '("40-if-else"
- "41-?"
- "42-goto-label"
- "43-for-do-while"
- "44-switch"
- "45-void-call"))
-
-(add-target (group "check-scaffold-tests/4" #:dependencies (filter (target-prefix? "check-scaffold/tests/4") %targets)))
-
-;; tests/50: libc-mes.c
-(for-each
- add-scaffold-test
- '("50-assert"
- "51-strcmp"
- "52-itoa"
- "54-argv"))
-
-(add-target (group "check-scaffold-tests/5" #:dependencies (filter (target-prefix? "check-scaffold/tests/5") %targets)))
-
-;; tests/60: building up to scaffold/m.c, scaffold/micro-mes.c
-(for-each
- add-scaffold-test
- '("60-math"
- "61-array"
- "63-struct-cell"
- "64-make-cell"
- "65-read"
- "66-local-char-array"))
-
-(add-target (group "check-scaffold-tests/6" #:dependencies (filter (target-prefix? "check-scaffold/tests/6") %targets)))
-
-;; tests/70: and beyond src/mes.c -- building up to 8cc.c, pcc.c, tcc.c, libguile/eval.c
-(for-each
- add-scaffold-test
- '("70-printf"
- "71-struct-array"
- "72-typedef-struct-def"
- "73-union"
- "74-multi-line-string"
- "75-struct-union"
- "76-pointer-arithmetic"
- "77-pointer-assign"
- "78-union-struct"
- "79-int-array"
- "7a-struct-char-array"
- "7b-struct-int-array"
- "7c-dynarray"
- "7d-cast-char"
- "7e-struct-array-access"
- "7f-struct-pointer-arithmetic"
- "7g-struct-byte-word-field"
- "7h-struct-assign"
- "7i-struct-struct"
- "7j-strtoull"
- "7k-for-each-elem"
- "7l-struct-any-size-array"
- "7m-struct-char-array-assign"
- "7n-struct-struct-array"))
-
-(add-target (group "check-scaffold-tests/7" #:dependencies (filter (target-prefix? "check-scaffold/tests/7") %targets)))
-
-(add-target (group "check-scaffold-tests" #:dependencies (filter (target-prefix? "check-scaffold/tests") %targets)))
-
-;; tests/80: and beyond tinycc; building GNU GCC and dependencies
-(for-each
- (cut add-scaffold-test <> #:libc libc+tcc-mes.hex2 #:libc-gcc libc+tcc-gcc.mlibc-o)
- '("80-setjmp"
- "81-qsort"
- "82-define"))
-
-(add-target (group "check-scaffold-tests/8" #:dependencies (filter (target-prefix? "check-scaffold/tests/8") %targets)))
-
-(add-target (group "check-scaffold-tests" #:dependencies (filter (target-prefix? "check-scaffold/tests") %targets)))
-
-(add-target (cpp.mescc "lib/libc+tcc-mes.c"))
-(add-target (compile.mescc "lib/libc+tcc-mes.c"))
-
-(define* (add-tcc-test name)
- (add-target (bin.gcc (string-append "scaffold/tinycc/" name ".c") #:libc libc-gcc.mlibc-o #:includes '("scaffold/tinycc")))
- (add-target (check (string-append "scaffold/tinycc/" name ".mlibc-gcc") #:baseline (string-append "scaffold/tinycc/" name ".expect")))
-
- (add-target (bin.mescc (string-append "scaffold/tinycc/" name ".c") #:includes '("scaffold/tinycc")))
- (add-target (check (string-append "scaffold/tinycc/" name ".guile") #:baseline (string-append "scaffold/tinycc/" name ".expect"))))
-(map
- add-tcc-test
- '("00_assignment"
- "01_comment"
- "02_printf"
- "03_struct"
- "04_for"
- "05_array"
- "06_case"
- "07_function"
- "08_while"
- "09_do_while"
-
- "10_pointer"
- "11_precedence"
- "12_hashdefine"
- "13_integer_literals"
- "14_if"
- "15_recursion"
- "16_nesting"
- "17_enum"
- "18_include"
- "19_pointer_arithmetic"
-
- "20_pointer_comparison"
- "21_char_array"
- ;;"22_floating_point" ; float
- ;;"23_type_coercion" ; float
- ;;"24_math_library" ; float
- "25_quicksort"
- ;;"27_sizeof" ; float
- ;;"28_strings" ; TODO: strncpy strchr strrchr memset memcpy memcmp
- "29_array_address"
-
- ;;"30_hanoi" ; fails with GCC
- "31_args"
- ;;"32_led" ; unsupported: (decl (decl-spec-list (stor-spec (static)) (type-spec (fixed-type "int"))) (init-declr-list (init-declr (array-of (ident "d") (p-expr (fixed "32"))))))
- ;;"34_array_assignment" ; fails with GCC
- "33_ternary_op"
- "35_sizeof"
- ;;"36_array_initialisers" ; unspported: (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (array-of (ident "Array") (p-expr (fixed "10"))) (initzer (initzer-list (initzer (p-expr (fixed "12"))) (initzer (p-expr (fixed "34"))) (initzer (p-expr (fixed "56"))) (initzer (p-expr (fixed "78"))) (initzer (p-expr (fixed "90"))) (initzer (p-expr (fixed "123"))) (initzer (p-expr (fixed "456"))) (initzer (p-expr (fixed "789"))) (initzer (p-expr (fixed "8642"))) (initzer (p-expr (fixed "9753"))))))))
- ;; "37_sprintf" ; integer formatting unsupported
- ;;"38_multiple_array_index" ; unspported: (decl (decl-spec-list (type-spec (fixed-type "int"))) (init-declr-list (init-declr (array-of (array-of (ident "a") (p-expr (fixed "4"))) (p-expr (fixed "4"))))))
- ;;"39_typedef" ; unsupported: (decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename "MyFunStruct"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "MoreFunThanEver")))))
-
- ;;"40_stdio" ; f* functions
- "41_hashif"
- ;;"42_function_pointer" ; f* functions
- "43_void_param"
- "44_scoped_declarations"
- "45_empty_for" ; unsupported
- ;;"46_grep" ; f* functions
- "47_switch_return"
- "48_nested_break"
- ;;"49_bracket_evaluation" ; float
-
- "50_logical_second_arg"
- ;;"51_static" ; unsupported: (decl (decl-spec-list (stor-spec (static)) (type-spec (fixed-type "int"))) (init-declr-list (init-declr (ident "fred") (initzer (p-expr (fixed "1234"))))))
- ;;"52_unnamed_enum" ; unsupported: (decl (decl-spec-list (stor-spec (typedef)) (type-spec (enum-def (enum-def-list (enum-defn (ident "e")) (enum-defn (ident "f")) (enum-defn (ident "g")))))) (init-declr-list (init-declr (ident "h"))))
- "54_goto"
- ;;"55_lshift_type" ; unsigned
- ))
-
-(add-target (group "check-scaffold-tinycc" #:dependencies (filter (target-prefix? "check-scaffold/tinycc") %targets)))
-
-;;(add-target (group "check-scaffold" #:dependencies (filter (target-prefix? "check-scaffold") %targets)))
-
-(add-target (bin.gcc "scaffold/main.c"))
-(add-target (check "scaffold/main.gcc" #:exit 42))
-
-(add-target (bin.gcc "scaffold/main.c" #:libc #f))
-(add-target (check "scaffold/main.mlibc-gcc" #:exit 42))
-
-(add-target (bin.mescc "scaffold/main.c" #:libc mini-libc-mes.hex2))
-(add-target (check "scaffold/main.mini-guile" #:exit 42))
-
-(add-target (bin.mescc "scaffold/main.c"))
-(add-target (check "scaffold/main.guile" #:exit 42))
-
-
-(add-target (bin.gcc "scaffold/hello.c"))
-(add-target (check "scaffold/hello.gcc" #:exit 42))
-
-(add-target (bin.gcc "scaffold/hello.c" #:libc libc-gcc.mlibc-o))
-(add-target (check "scaffold/hello.mlibc-gcc" #:exit 42))
-
-(add-target (bin.mescc "scaffold/hello.c" #:libc mini-libc-mes.hex2))
-(add-target (check "scaffold/hello.mini-guile" #:exit 42))
-
-(add-target (bin.mescc "scaffold/hello.c"))
-(add-target (check "scaffold/hello.guile" #:exit 42))
-
-
-(add-target (bin.gcc "scaffold/m.c"))
-(add-target (check "scaffold/m.gcc" #:exit 255))
-
-(add-target (bin.gcc "scaffold/m.c" #:libc libc-gcc.mlibc-o))
-(add-target (check "scaffold/m.mlibc-gcc" #:exit 255))
-
-(add-target (bin.mescc "scaffold/m.c"))
-(add-target (check "scaffold/m.guile" #:exit 255))
-
-(add-target (bin.gcc "scaffold/micro-mes.c" #:libc libc-gcc.mlibc-o))
-(add-target (check "scaffold/micro-mes.mlibc-gcc" #:exit 6)) ; arg1 arg2 arg3 arg4 arg5
-
-(add-target (bin.mescc "scaffold/micro-mes.c"))
-(add-target (check "scaffold/micro-mes.guile" #:exit 6)) ; arg1 arg2 arg3 arg4 arg5
-
-(add-target (group "check-scaffold" #:dependencies (filter (target-prefix? "check-scaffold") %targets)))
-
-(define snarf-bases
- '("gc" "lib" "math" "mes" "posix" "reader" "vector"))
-
-(define bla
- `(,@(map (cut string-append "src/" <> ".c") snarf-bases)
- ,@(map (cut string-append "src/" <> ".mes.h") snarf-bases)
- ,@(map (cut string-append "src/" <> ".mes.i") snarf-bases)
- ,@(map (cut string-append "src/" <> ".mes.environment.i") snarf-bases)))
-
-(define gcc-snarf-targets
- (list
- (add-target (snarf "src/gc.c" #:mes? #f))
- (add-target (snarf "src/lib.c" #:mes? #f))
- (add-target (snarf "src/math.c" #:mes? #f))
- (add-target (snarf "src/mes.c" #:mes? #f))
- (add-target (snarf "src/posix.c" #:mes? #f))
- (add-target (snarf "src/reader.c" #:mes? #f))
- (add-target (snarf "src/vector.c" #:mes? #f))))
-
-(define mes-snarf-targets
- (list
- (add-target (snarf "src/gc.c"))
- (add-target (snarf "src/lib.c" #:mes? #t))
- (add-target (snarf "src/math.c" #:mes? #t))
- (add-target (snarf "src/mes.c" #:mes? #t))
- (add-target (snarf "src/posix.c" #:mes? #t))
- (add-target (snarf "src/reader.c" #:mes? #t))
- (add-target (snarf "src/vector.c" #:mes? #t))))
-
-(add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets
- #:defines `("POSIX=1"
- ,(string-append "VERSION=\"" %version "\"")
- ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
- ,(string-append "PREFIX=\"" %prefix "\""))
- #:includes '("src")))
-
-(add-target (bin.gcc "src/mes.c" #:libc libc-gcc.mlibc-o
- #:dependencies mes-snarf-targets
- #:defines `(,(string-append "VERSION=\"" %version "\"")
- ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
- ,(string-append "PREFIX=\"" %prefix "\""))
- #:includes '("src")))
-
-(add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets
- #:defines `(,(string-append "VERSION=\"" %version "\"")
- ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
- ,(string-append "PREFIX=\"" %prefix "\""))
- #:includes '("src")))
-
-(define mes-tests
- '("tests/boot.test"
- "tests/read.test"
- "tests/base.test"
- "tests/quasiquote.test"
- "tests/let.test"
- "tests/closure.test"
- "tests/scm.test"
- "tests/display.test"
- "tests/cwv.test"
- "tests/math.test"
- "tests/vector.test"
- "tests/srfi-1.test"
- "tests/srfi-13.test"
- "tests/srfi-14.test"
- "tests/srfi-16.test"
- "tests/srfi-43.test"
- "tests/optargs.test"
- "tests/fluids.test"
- "tests/catch.test"
- "tests/record.test"
- "tests/getopt-long.test"
- "tests/guile.test"
- "tests/syntax.test"
- "tests/let-syntax.test"
- "tests/pmatch.test"
- "tests/match.test"
- "tests/psyntax.test"
- ;;sloooowwww/broken?
- ;;"tests/peg.test"
- ))
-
-(define (add-guile-test o)
- (add-target (target (file-name o)))
- (add-target (check o)))
-
-(define (add-mes.gcc-test o)
- (add-target (target (file-name o)))
- (add-target (check o #:dependencies (list (get-target "src/mes.mlibc-gcc")))))
-
-(define (add-mes.guile-test o)
- (add-target (target (file-name o)))
- (add-target (check o #:dependencies (list (get-target "src/mes.guile")))))
-
-(for-each add-guile-test (map (cut string-append <> "-guile") mes-tests))
-
-;; takes long, and should always pass if...
-;;(for-each add-mes.gcc-test mes-tests)
-
-;; ...mes.guile passes :-)
-(for-each add-mes.guile-test mes-tests)
-
-(add-target (group "check-tests" #:dependencies (filter (target-prefix? "check-tests/") %targets)))
-
-(add-target (install "scripts/mescc" #:dir "bin" #:substitutes #t))
-(define bootstrap? #f)
-(if bootstrap?
- (add-target (install "src/mes.mes" #:dir "bin" #:installed-name "mes"))
- (add-target (install "src/mes.guile" #:dir "bin" #:installed-name "mes")))
-
-(define* ((install-dir #:key dir) name)
- (add-target (install name #:dir (string-append dir "/" (dirname name)))))
-
-(add-target (install "module/mes/boot-0.scm" #:dir (string-append %moduledir "/mes") #:substitutes #t))
-(add-target (install "module/language/c99/compiler.mes" #:dir (string-append %moduledir "/language/c99") #:substitutes #t))
-
-(define %module-dir "share/mes")
-(for-each
- (lambda (f)
- ((install-dir #:dir (string-append %module-dir)) f))
- '(;;"module/language/c99/compiler.mes"
- "module/language/c99/compiler.scm"
- "module/language/c99/info.mes"
- "module/language/c99/info.scm"
- "module/language/paren.mes"
- "module/mes/M1.mes"
- "module/mes/M1.scm"
- "module/mes/as-i386.mes"
- "module/mes/as-i386.scm"
- "module/mes/as.mes"
- "module/mes/as.scm"
- "module/mes/base.mes"
- ;;"module/mes/boot-0.scm"
- "module/mes/boot-00.scm"
- "module/mes/boot-01.scm"
- "module/mes/boot-02.scm"
- "module/mes/bytevectors.mes"
- "module/mes/bytevectors.scm"
- "module/mes/catch.mes"
- "module/mes/display.mes"
- "module/mes/elf.mes"
- "module/mes/elf.scm"
- "module/mes/fluids.mes"
- "module/mes/getopt-long.mes"
- "module/mes/getopt-long.scm"
- "module/mes/guile.mes"
- "module/mes/guile.scm"
- "module/mes/lalr.mes"
- "module/mes/lalr.scm"
- "module/mes/let.mes"
- "module/mes/match.mes"
- "module/mes/match.scm"
- "module/mes/module.mes"
- "module/mes/optargs.mes"
- "module/mes/optargs.scm"
- "module/mes/peg.mes"
- "module/mes/peg/cache.scm"
- "module/mes/peg/codegen.scm"
- "module/mes/peg/simplify-tree.scm"
- "module/mes/peg/string-peg.scm"
- "module/mes/peg/using-parsers.scm"
- "module/mes/pmatch.mes"
- "module/mes/pmatch.scm"
- "module/mes/posix.mes"
- "module/mes/pretty-print.mes"
- "module/mes/pretty-print.scm"
- "module/mes/psyntax-0.mes"
- "module/mes/psyntax-1.mes"
- "module/mes/psyntax.mes"
- "module/mes/psyntax.pp"
- "module/mes/psyntax.ss"
- "module/mes/quasiquote.mes"
- "module/mes/quasisyntax.mes"
- "module/mes/quasisyntax.scm"
- "module/mes/repl.mes"
- "module/mes/scm.mes"
- "module/mes/syntax.mes"
- "module/mes/syntax.scm"
- "module/mes/test.mes"
- "module/mes/tiny-0.mes"
- "module/mes/type-0.mes"
- "module/nyacc/lalr.mes"
- "module/nyacc/lang/c99/cpp.mes"
- "module/nyacc/lang/c99/parser.mes"
- "module/nyacc/lang/c99/pprint.mes"
- "module/nyacc/lang/calc/parser.mes"
- "module/nyacc/lang/util.mes"
- "module/nyacc/lex.mes"
- "module/nyacc/parse.mes"
- "module/nyacc/util.mes"
- "module/rnrs/arithmetic/bitwise.mes"
- "module/srfi/srfi-0.mes"
- "module/srfi/srfi-1.mes"
- "module/srfi/srfi-1.scm"
- "module/srfi/srfi-13.mes"
- "module/srfi/srfi-14.mes"
- "module/srfi/srfi-16.mes"
- "module/srfi/srfi-16.scm"
- "module/srfi/srfi-26.mes"
- "module/srfi/srfi-26.scm"
- "module/srfi/srfi-43.mes"
- "module/srfi/srfi-9.mes"
- "module/sxml/xpath.mes"
- "module/sxml/xpath.scm"))
-
-(define* ((install-guile-dir #:key dir) name)
- (add-target (install (string-append "guile/" name) #:dir (string-append dir "/" (dirname name)))))
-
-(for-each
- (lambda (f)
- ((install-guile-dir #:dir (string-append %guiledir)) f))
- %scm-files)
-
-(for-each
- (lambda (f)
- ((install-guile-dir #:dir (string-append %godir)) f))
- %go-files)
-
-(add-target (install "lib/crt1.hex2" #:dir "lib"))
-(add-target (install "lib/libc-mes.M1" #:dir "lib"))
-(add-target (install "lib/libc-mes.hex2" #:dir "lib"))
-(add-target (install "lib/libc+tcc-mes.M1" #:dir "lib"))
-(add-target (install "lib/libc+tcc-mes.hex2" #:dir "lib"))
-(add-target (install "lib/mini-libc-mes.M1" #:dir "lib"))
-(add-target (install "lib/mini-libc-mes.hex2" #:dir "lib"))
-
-(add-target (install "lib/crt1.mlibc-o" #:dir "lib"))
-(add-target (install "lib/libc-gcc.mlibc-o" #:dir "lib"))
-(add-target (install "lib/libc+tcc-gcc.mlibc-o" #:dir "lib"))
-
-(for-each
- (lambda (f)
- ((install-dir #:dir "share/") f))
- '("include/alloca.h"
- "include/assert.h"
- "include/ctype.h"
- "include/dlfcn.h"
- "include/errno.h"
- "include/fcntl.h"
- "include/features.h"
- "include/inttypes.h"
- "include/libgen.h"
- "include/limits.h"
- "include/locale.h"
- "include/math.h"
- "include/mlibc.h"
- "include/setjmp.h"
- "include/signal.h"
- "include/stdarg.h"
- "include/stdbool.h"
- "include/stdint.h"
- "include/stdio.h"
- "include/stdlib.h"
- "include/stdnoreturn.h"
- "include/string.h"
- "include/strings.h"
- "include/sys/cdefs.h"
- "include/sys/mman.h"
- "include/sys/stat.h"
- "include/sys/time.h"
- "include/sys/timeb.h"
- "include/sys/types.h"
- "include/sys/ucontext.h"
- "include/sys/wait.h"
- "include/time.h"
- "include/unistd.h"))
-
-(for-each
- (compose add-target (cut install <> #:dir "share/doc/mes"))
- '("AUTHORS"
- ;;"ChangeLog"
- "BOOTSTRAP"
- "COPYING"
- "HACKING"
- "INSTALL"
- "NEWS"
- "README"
- "doc/ANNOUNCE-0.11"))
-
-(add-target (install "doc/fosdem/fosdem.pdf" #:dir "share/doc/mes"))
-
-(define (main args)
- (cond ((member "all-go" args) #t)
- ((member "clean-go" args) (map delete-file (filter file-exists? %go-files)))
- ((member "clean" args) (clean))
- ((member "list" args) (display (string-join (map target-file-name %targets) "\n" 'suffix)))
- ((member "help" args) (format #t "Usage: ./make.scm [TARGET]...
-
-Targets:
- all
- all-go
- check
- clean
- clean-go
- help~a
- install
- list
-"
- (string-join (filter (negate (cut string-index <> #\/)) (map target-file-name %targets)) "\n " 'prefix)))
- (else
- (let ((targets (match args
- (() (filter (conjoin (negate install-target?)
- (negate check-target?))
- %targets))
- ((? (cut member "all" <>)) (filter (conjoin (negate install-target?)
- (negate check-target?))
- %targets))
- ((? (cut member "check" <>)) (filter check-target? %targets))
- ((? (cut member "install" <>)) (filter install-target? %targets))
- (_ (filter-map (cut get-target <>) args)))))
- ;;((@@ (guix make) store) #:print 0)
- (for-each build targets)
- (exit %status)))))
-
-(main (cdr (command-line)))
(info (append-text info (wrap-as (i386:pop-accu)))))
info)))
+(define (comment? o)
+ (and (pair? o) (pair? (car o)) (eq? (caar o) #:comment)))
+
(define (clause->info info i label last?)
(define clause-label
(string-append label "clause" (number->string i)))
info))
((or ,a ,b)
- (let* ((here (number->string (length (.text info))))
+ (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))
*/
#define MES_MINI 1
+//#define HAVE_UNION 1
#if POSIX
#error "POSIX not supported"
#endif
#include <string.h>
#include <mlibc.h>
-int ARENA_SIZE = 100000;
-int MAX_ARENA_SIZE = 40000000;
-int GC_SAFETY = 10000;
+int ARENA_SIZE = 200000; // 32b: 2MiB, 64b: 4 MiB
+int MAX_ARENA_SIZE = 300000000;
+int JAM_SIZE = 20000;
+int GC_SAFETY = 2000;
char *g_arena = 0;
typedef int SCM;
SCM g_continuations = 0;
SCM g_symbols = 0;
SCM g_macros = 0;
+SCM g_ports = 0;
SCM g_stack = 0;
// a/env
SCM r0 = 0;
// continuation
SCM r3 = 0;
-enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
+enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
struct scm {
enum type_t type;
struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
+struct scm scm_type_char = {TSYMBOL, "<cell:char>",0};
+struct scm scm_type_closure = {TSYMBOL, "<cell:closure>",0};
+struct scm scm_type_continuation = {TSYMBOL, "<cell:continuation>",0};
+struct scm scm_type_function = {TSYMBOL, "<cell:function>",0};
+struct scm scm_type_keyword = {TSYMBOL, "<cell:keyword>",0};
+struct scm scm_type_macro = {TSYMBOL, "<cell:macro>",0};
+struct scm scm_type_number = {TSYMBOL, "<cell:number>",0};
+struct scm scm_type_pair = {TSYMBOL, "<cell:pair>",0};
+struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
+struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
+struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
+struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
+struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
+struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
+struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
+struct scm scm_type_vector = {TSYMBOL, "<cell:vector>",0};
+struct scm scm_type_broken_heart = {TSYMBOL, "<cell:broken-heart>",0};
+
struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
#define FUNCTION(x) g_functions[g_cells[x].cdr]
#define MACRO(x) g_cells[x].cdr
+#define PORT(x) g_cells[x].cdr
#define VALUE(x) g_cells[x].cdr
#define VECTOR(x) g_cells[x].cdr
SCM
append2 (SCM x, SCM y)
{
- if (x == cell_nil) return y;
- assert (TYPE (x) == TPAIR);
- return cons (car (x), append2 (cdr (x), y));
+ if (x == cell_nil)
+ return y;
+ if (TYPE (x) != TPAIR)
+ error (cell_symbol_not_a_pair, cons (x, cell_append2));
+ SCM r = cell_nil;
+ while (x != cell_nil)
+ {
+ r = cons (CAR (x), r);
+ x = CDR (x);
+ }
+ return reverse_x_ (r, y);
+}
+
+SCM
+append_reverse (SCM x, SCM y)
+{
+ if (x == cell_nil)
+ return y;
+ if (TYPE (x) != TPAIR)
+ error (cell_symbol_not_a_pair, cons (x, cell_append_reverse));
+ while (x != cell_nil)
+ {
+ y = cons (CAR (x), y);
+ x = CDR (x);
+ }
+ return y;
+}
+
+SCM
+reverse_x_ (SCM x, SCM t)
+{
+ if (TYPE (x) != TPAIR)
+ error (cell_symbol_not_a_pair, cons (x, cell_reverse_x_));
+ SCM r = t;
+ while (x != cell_nil)
+ {
+ t = CDR (x);
+ CDR (x) = r;
+ r = x;
+ x = t;
+ }
+ return r;
}
SCM
return frame;
}
+char const* string_to_cstring (SCM s);
+
+SCM
+add_formals (SCM formals, SCM x)
+{
+ while (TYPE (x) == TPAIR)
+ {
+ formals = cons (CAR (x), formals);
+ x = CDR (x);
+ }
+ if (TYPE (x) == TSYMBOL)
+ formals = cons (x, formals);
+ return formals;
+}
+
SCM
eval_apply ()
{
- return scm_unspecified;
+ return cell_unspecified;
}
SCM
return 0;
}
-SCM
-gc_init_news () ///((internal))
-{
- eputs ("gc_init_news\n");
- ///g_news = g_cells-1 + ARENA_SIZE;
- //g_news = g_cells + ARENA_SIZE * 12 + GC_SAFETY * 6;
- char *p = g_cells;
- // g_news = g_cells;
- int halfway = ARENA_SIZE * 12;
- int safety = GC_SAFETY * 12;
- safety = safety / 2;
- halfway = halfway + safety;
- // g_news = g_news + halfway;
- p = p + halfway;
- g_news = p;
- eputs ("g_cells=");
- eputs (itoa (g_cells));
- eputs (" size=");
- eputs (itoa (halfway));
- eputs (" news=");
- eputs (itoa (g_news));
- eputs (" news - cells=");
- char * c = g_cells;
- eputs (itoa (p - c));
- eputs ("\n");
-
-
- NTYPE (0) = TVECTOR;
- NLENGTH (0) = 1000;
- NVECTOR (0) = 0;
- g_news++;
- NTYPE (0) = TCHAR;
- NVALUE (0) = 'n';
- return 0;
-}
-
SCM
mes_symbols () ///((internal))
{
else
MES=${MES-$(dirname $0)/mes}
PREFIX=${PREFIX-@PREFIX@}
- MES_PREFIX=${MES_PREFIX-$PREFIX}
if [ "$MES_PREFIX" = @PREFIX""@ ]
then
MES_PREFIX=$(cd $(dirname $0)/.. && pwd)
export MES_PREFIX
+ else
+ MES_PREFIX=${MES_PREFIX-$PREFIX/share/mes}
fi
MES_MODULEDIR=${MES_MODULEDIR-$MES_PREFIX/"module"}
export MES_MODULEDIR
(cond-expand
(mes
- (define %scheme "mes"))
+ (define %scheme "mes")
+ (define (set-port-encoding! port encoding) #t))
(guile-2
(define %scheme "guile")
(define-macro (mes-use-module . rest) #t)
(define (ast? o)
(or (string-suffix? ".E" o)
- (string-suffix? (string-append "." %scheme "-E") o)))
+ (string-suffix? (string-append "." %scheme "-E") o)
+ (string-suffix? "-E" o)))
(define (object? o)
(or (string-suffix? ".o" o)
- (string-suffix? (string-append "." %scheme "-o") o)))
+ (string-suffix? (string-append "." %scheme "-o") o)
+ (string-suffix? "-o" o)))
(define (main args)
(let* ((options (parse-opts args))
{
r0 = a;
g_stdin = -1;
- char boot[128];
- char buf[128];
+ char boot[1024];
+ char buf[1024];
if (getenv ("MES_BOOT"))
strcpy (boot, getenv ("MES_BOOT"));
else
}
if (g_stdin < 0)
{
- char const *prefix = MODULEDIR "mes/";
+ char const *prefix = MODULEDIR "/mes/";
strcpy (buf, prefix);
strcpy (buf + strlen (buf), boot);
if (getenv ("MES_DEBUG"))
#if !_POSIX_SOURCE
char *mo = "mes/read-0-32.mo";
g_stdin = open ("module/mes/boot-0.32-mo", O_RDONLY);
- char *read0 = MODULEDIR "mes/boot-0.32-mo";
+ char *read0 = MODULEDIR "/mes/boot-0.32-mo";
g_stdin = g_stdin >= 0 ? g_stdin : open (read0, O_RDONLY);
#else
char *mo ="mes/boot-0.mo";
g_stdin = open ("module/mes/boot-0.mo", O_RDONLY);
- g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "mes/boot-0.mo", O_RDONLY);
+ g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "/mes/boot-0.mo", O_RDONLY);
#endif
if (g_stdin < 0)
+++ /dev/null
-#! /bin/sh
-
-# 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/>.
-
-set -ex
-
-t=${1-t}
-rm -f "$t".i686-unknown-linux-gnu-out
-rm -f "$t".mes-out
-
-M1=${M1-M1}
-HEX2=${HEX2-hex2}
-MES=${MES-guile}
-MESCC=${MESCC-scripts/mescc}
-
-sh $MESCC -E -o scaffold/tests/$t.E scaffold/tests/$t.c
-sh $MESCC -c -o scaffold/tests/$t.M1 scaffold/tests/$t.E
-$M1 --LittleEndian --Architecture=1\
- -f stage0/x86.M1\
- -f scaffold/tests/$t.M1\
- -o scaffold/tests/$t.hex2
-
-# $MESCC -E -o lib/crt1.E lib/crt1.c
-# $MESCC -c -o lib/crt1.M1 lib/crt1.E
-# $M1 --LittleEndian --Architecture=1 \
-# -f stage0/x86.M1\
-# -f lib/crt1.M1\
-# -o lib/crt1.hex2
-# $MESCC -E -o lib/libc-mes.E lib/libc-mes.c
-# $MESCC -c -o lib/libc-mes.M1 lib/libc-mes.E
-# $M1 --LittleEndian --Architecture=1\
-# -f stage0/x86.M1\
-# -f lib/libc-mes.M1\
-# -o lib/libc-mes.hex2
-
-$HEX2 --LittleEndian --Architecture=1 --BaseAddress=0x1000000\
- -f stage0/elf32-header.hex2\
- -f lib/crt1.hex2\
- -f lib/libc-mes.hex2\
- -f scaffold/tests/$t.hex2\
- -f stage0/elf32-footer-single-main.hex2\
- -o scaffold/tests/$t.mes-out
-chmod +x scaffold/tests/$t.mes-out
-
-r=0
-set +e
-scaffold/tests/$t.mes-out
-m=$?
-
-[ $m = $r ]
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
+MES=${MES-$(dirname $0)/../src/mes}
export MES_BOOT=boot-02.scm
$MES < $0
exit $?
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-166000000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-200000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
#paredit:||
exit $?
#! /bin/sh
# -*-scheme-*-
# ***REMOVE THIS BLOCK COMMENT INITIALLY***
-MES=${MES-$(dirname $0)/../src/mes.gcc}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
#! /bin/sh
# -*-scheme-*-
-MES=${MES-$(dirname $0)/../src/mes.gcc}
-#export MES_ARENA=${MES_ARENA-40000}
+MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#
projects / mes.git / commitdiff