From a937d18c3848fd46c0d9bcd106dab250446a86a6 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 29 Apr 2018 18:38:57 +0200 Subject: [PATCH] build: Simplify, drop make.scm experiment. * 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. --- .gitignore | 5 + GNUmakefile | 31 +- build-aux/build-cc.sh | 51 ++ build-aux/build-guile.sh | 38 ++ build-aux/build-mes.sh | 97 +++ build-aux/build-mlibc.sh | 71 +++ build-aux/cc-mes.sh | 88 +++ build-aux/cc-mlibc.sh | 59 ++ build-aux/cc.sh | 54 ++ check-boot.sh => build-aux/check-boot.sh | 0 build-aux/check-mescc.sh | 237 ++++++++ build-aux/mes-snarf.scm | 4 +- build-aux/test.sh | 37 ++ build.sh | 71 +-- check-mescc.sh | 141 ----- check.sh | 6 +- guile/guix/make.scm | 546 ----------------- guile/guix/records.scm | 378 ------------ guile/guix/shell-utils.scm | 225 ------- install.sh | 43 +- make.scm | 720 ----------------------- module/language/c99/compiler.mes | 6 +- scaffold/mini-mes.c | 128 ++-- scripts/mescc | 12 +- src/mes.c | 10 +- test.sh | 66 --- tests/base.test | 2 +- tests/boot.test | 2 +- tests/catch.test | 3 +- tests/closure.test | 3 +- tests/cwv.test | 3 +- tests/display.test | 2 +- tests/fluids.test | 3 +- tests/getopt-long.test | 3 +- tests/guile.test | 3 +- tests/let-syntax.test | 3 +- tests/let.test | 3 +- tests/match.test | 3 +- tests/math.test | 3 +- tests/module.test | 3 +- tests/optargs.test | 3 +- tests/peg.test | 3 +- tests/pmatch.test | 3 +- tests/psyntax.test | 3 +- tests/quasiquote.test | 3 +- tests/read.test | 2 +- tests/record.test | 3 +- tests/scm.test | 3 +- tests/srfi-1.test | 3 +- tests/srfi-13.test | 3 +- tests/srfi-14.test | 3 +- tests/srfi-16.test | 3 +- tests/srfi-43.test | 3 +- tests/syntax.test | 3 +- tests/vector.test | 3 +- 55 files changed, 955 insertions(+), 2252 deletions(-) create mode 100755 build-aux/build-cc.sh create mode 100755 build-aux/build-guile.sh create mode 100755 build-aux/build-mes.sh create mode 100755 build-aux/build-mlibc.sh create mode 100755 build-aux/cc-mes.sh create mode 100755 build-aux/cc-mlibc.sh create mode 100755 build-aux/cc.sh rename check-boot.sh => build-aux/check-boot.sh (100%) create mode 100755 build-aux/check-mescc.sh create mode 100755 build-aux/test.sh delete mode 100755 check-mescc.sh delete mode 100644 guile/guix/make.scm delete mode 100644 guile/guix/records.scm delete mode 100644 guile/guix/shell-utils.scm delete mode 100755 make.scm delete mode 100755 test.sh diff --git a/.gitignore b/.gitignore index ea64ef76..b56da706 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,6 @@ *- +*.blood-elf-M1 +*.blood-elf-hex2 *.go *~ .#* @@ -32,7 +34,10 @@ /.tarball-version /ChangeLog /a.out +*.gcc-out *.mes-out +*.mlibc-out +*.seed-out #keep this: bootstrap #/mes.mes diff --git a/GNUmakefile b/GNUmakefile index 9a233667..9025f243 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -6,13 +6,34 @@ include .config.make 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 diff --git a/build-aux/build-cc.sh b/build-aux/build-cc.sh new file mode 100755 index 00000000..05796972 --- /dev/null +++ b/build-aux/build-cc.sh @@ -0,0 +1,51 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh new file mode 100755 index 00000000..26ef74ed --- /dev/null +++ b/build-aux/build-guile.sh @@ -0,0 +1,38 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/build-aux/build-mes.sh b/build-aux/build-mes.sh new file mode 100755 index 00000000..e7cc853b --- /dev/null +++ b/build-aux/build-mes.sh @@ -0,0 +1,97 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/build-aux/build-mlibc.sh b/build-aux/build-mlibc.sh new file mode 100755 index 00000000..a6e40b18 --- /dev/null +++ b/build-aux/build-mlibc.sh @@ -0,0 +1,71 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/build-aux/cc-mes.sh b/build-aux/cc-mes.sh new file mode 100755 index 00000000..2a51db5e --- /dev/null +++ b/build-aux/cc-mes.sh @@ -0,0 +1,88 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/build-aux/cc-mlibc.sh b/build-aux/cc-mlibc.sh new file mode 100755 index 00000000..e5bd8dd5 --- /dev/null +++ b/build-aux/cc-mlibc.sh @@ -0,0 +1,59 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/build-aux/cc.sh b/build-aux/cc.sh new file mode 100755 index 00000000..0929a205 --- /dev/null +++ b/build-aux/cc.sh @@ -0,0 +1,54 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/check-boot.sh b/build-aux/check-boot.sh similarity index 100% rename from check-boot.sh rename to build-aux/check-boot.sh diff --git a/build-aux/check-mescc.sh b/build-aux/check-mescc.sh new file mode 100755 index 00000000..d36da3d2 --- /dev/null +++ b/build-aux/check-mescc.sh @@ -0,0 +1,237 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 64a8fc4f..ed57bc67 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -65,12 +65,12 @@ exec ${GUILE-guile} -L $(dirname 0) -e '(mes-snarf)' -s "$0" "$@" (define %gcc? #t) -(define-record-type file (make-file name content) +(define-record-type (make-file name content) file? (name file.name) (content file.content)) -(define-record-type function (make-function name formals annotation) +(define-record-type (make-function name formals annotation) function? (name function.name) (formals function.formals) diff --git a/build-aux/test.sh b/build-aux/test.sh new file mode 100755 index 00000000..4454c488 --- /dev/null +++ b/build-aux/test.sh @@ -0,0 +1,37 @@ +#! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +# +# 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 . + +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 diff --git a/build.sh b/build.sh index e7ff09e4..df558c07 100755 --- a/build.sh +++ b/build.sh @@ -20,54 +20,31 @@ 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 diff --git a/check-mescc.sh b/check-mescc.sh deleted file mode 100755 index 598a7464..00000000 --- a/check-mescc.sh +++ /dev/null @@ -1,141 +0,0 @@ -#! /bin/sh - -# Mes --- Maxwell Equations of Software -# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen -# -# 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 . - -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 diff --git a/check.sh b/check.sh index cfdb6142..9636c0c3 100755 --- a/check.sh +++ b/check.sh @@ -20,10 +20,10 @@ 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 @@ -85,4 +85,4 @@ else echo PASS: $total fi -sh check-mescc.sh +sh build-aux/check-mescc.sh diff --git a/guile/guix/make.scm b/guile/guix/make.scm deleted file mode 100644 index 470c920c..00000000 --- a/guile/guix/make.scm +++ /dev/null @@ -1,546 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -;;; 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 make-method - method? - (name method-name) - (build method-build (default (lambda _ #t))) - (inputs method-inputs (default (list)))) - -(define-record-type* - 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)) ; - (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)) diff --git a/guile/guix/records.scm b/guile/guix/records.scm deleted file mode 100644 index a019373b..00000000 --- a/guile/guix/records.scm +++ /dev/null @@ -1,378 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès -;;; -;;; 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 . - -(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 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 diff --git a/guile/guix/shell-utils.scm b/guile/guix/shell-utils.scm deleted file mode 100644 index c6007c8a..00000000 --- a/guile/guix/shell-utils.scm +++ /dev/null @@ -1,225 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès -;;; Copyright © 2013 Andreas Enge -;;; Copyright © 2013 Nikita Karetnikov -;;; Copyright © 2015 Mark H Weaver -;;; -;;; 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 . - -(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))))) - - -;;; -;;; 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))))))) - diff --git a/install.sh b/install.sh index 9e60e044..1c80a8b8 100755 --- a/install.sh +++ b/install.sh @@ -2,7 +2,7 @@ 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} @@ -12,17 +12,38 @@ cp src/mes $PREFIX/bin/mes 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 diff --git a/make.scm b/make.scm deleted file mode 100755 index 20a3ff28..00000000 --- a/make.scm +++ /dev/null @@ -1,720 +0,0 @@ -#! /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 -;;; -;;; 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 . - -(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))) diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index a1acea49..b1259b09 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -1314,6 +1314,9 @@ (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))) @@ -1403,7 +1406,8 @@ 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)) diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index c60a43b8..88b70c4a 100644 --- a/scaffold/mini-mes.c +++ b/scaffold/mini-mes.c @@ -19,6 +19,7 @@ */ #define MES_MINI 1 +//#define HAVE_UNION 1 #if POSIX #error "POSIX not supported" #endif @@ -29,9 +30,10 @@ #include #include -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; @@ -42,6 +44,7 @@ int g_free = 0; 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; @@ -52,7 +55,7 @@ SCM r2 = 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; @@ -172,6 +175,24 @@ struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0}; 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, "",0}; +struct scm scm_type_closure = {TSYMBOL, "",0}; +struct scm scm_type_continuation = {TSYMBOL, "",0}; +struct scm scm_type_function = {TSYMBOL, "",0}; +struct scm scm_type_keyword = {TSYMBOL, "",0}; +struct scm scm_type_macro = {TSYMBOL, "",0}; +struct scm scm_type_number = {TSYMBOL, "",0}; +struct scm scm_type_pair = {TSYMBOL, "",0}; +struct scm scm_type_port = {TSYMBOL, "",0}; +struct scm scm_type_ref = {TSYMBOL, "",0}; +struct scm scm_type_special = {TSYMBOL, "",0}; +struct scm scm_type_string = {TSYMBOL, "",0}; +struct scm scm_type_symbol = {TSYMBOL, "",0}; +struct scm scm_type_values = {TSYMBOL, "",0}; +struct scm scm_type_variable = {TSYMBOL, "",0}; +struct scm scm_type_vector = {TSYMBOL, "",0}; +struct scm scm_type_broken_heart = {TSYMBOL, "",0}; + struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0}; struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0}; @@ -216,6 +237,7 @@ int g_function = 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 @@ -513,9 +535,48 @@ gc_push_frame () ///((internal)) 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 @@ -656,10 +717,25 @@ gc_pop_frame () ///((internal)) 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 @@ -729,42 +805,6 @@ gc_init_cells () ///((internal)) 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)) { diff --git a/scripts/mescc b/scripts/mescc index eb7d4b9b..bc324ad8 100755 --- a/scripts/mescc +++ b/scripts/mescc @@ -12,11 +12,12 @@ if [ '(' -z "$mes_p" -a -z "$MES" ')' -o "$MES" = "guile" -o "$MES" = "mes.guile 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 @@ -63,7 +64,8 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' scripts/mescc (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) @@ -153,11 +155,13 @@ Environment variables: (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)) diff --git a/src/mes.c b/src/mes.c index d8cc4bd4..4f787929 100644 --- a/src/mes.c +++ b/src/mes.c @@ -2220,8 +2220,8 @@ load_env (SCM a) ///((internal)) { 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 @@ -2242,7 +2242,7 @@ load_env (SCM a) ///((internal)) } 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")) @@ -2296,12 +2296,12 @@ bload_env (SCM a) ///((internal)) #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) diff --git a/test.sh b/test.sh deleted file mode 100755 index 2f6c1c76..00000000 --- a/test.sh +++ /dev/null @@ -1,66 +0,0 @@ -#! /bin/sh - -# Mes --- Maxwell Equations of Software -# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen -# -# 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 . - -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 ] diff --git a/tests/base.test b/tests/base.test index eee59548..e9942df9 100755 --- a/tests/base.test +++ b/tests/base.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -MES=${MES-$(dirname $0)/../src/mes.gcc} +MES=${MES-$(dirname $0)/../src/mes} $MES -s $0 exit $? !# diff --git a/tests/boot.test b/tests/boot.test index 121540c6..753f4b6c 100755 --- a/tests/boot.test +++ b/tests/boot.test @@ -1,6 +1,6 @@ #! /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 $? diff --git a/tests/catch.test b/tests/catch.test index f3390ef8..62ee9e50 100755 --- a/tests/catch.test +++ b/tests/catch.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/closure.test b/tests/closure.test index 11dab07d..ea1acdb1 100755 --- a/tests/closure.test +++ b/tests/closure.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/cwv.test b/tests/cwv.test index dfc6b7ee..97135799 100755 --- a/tests/cwv.test +++ b/tests/cwv.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/display.test b/tests/display.test index a2d244d2..88d49647 100755 --- a/tests/display.test +++ b/tests/display.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -MES=${MES-$(dirname $0)/../src/mes.gcc} +MES=${MES-$(dirname $0)/../src/mes} $MES -s $0 exit $? !# diff --git a/tests/fluids.test b/tests/fluids.test index ea9521cf..3f22eff0 100755 --- a/tests/fluids.test +++ b/tests/fluids.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/getopt-long.test b/tests/getopt-long.test index 525c7194..237afa23 100755 --- a/tests/getopt-long.test +++ b/tests/getopt-long.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/guile.test b/tests/guile.test index 98699a29..2939a244 100755 --- a/tests/guile.test +++ b/tests/guile.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/let-syntax.test b/tests/let-syntax.test index b2860c35..0df7b211 100755 --- a/tests/let-syntax.test +++ b/tests/let-syntax.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/let.test b/tests/let.test index 8983036a..24483ebb 100755 --- a/tests/let.test +++ b/tests/let.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/match.test b/tests/match.test index d65129a0..1be8e5bd 100755 --- a/tests/match.test +++ b/tests/match.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/math.test b/tests/math.test index cdcd40fa..d9164355 100755 --- a/tests/math.test +++ b/tests/math.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/module.test b/tests/module.test index 7c1c0b4c..643645a0 100755 --- a/tests/module.test +++ b/tests/module.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/optargs.test b/tests/optargs.test index 9fcb2e1c..63b82f6e 100755 --- a/tests/optargs.test +++ b/tests/optargs.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/peg.test b/tests/peg.test index 9753a5a1..f6d40aac 100755 --- a/tests/peg.test +++ b/tests/peg.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/pmatch.test b/tests/pmatch.test index 5f844def..0c913fc2 100755 --- a/tests/pmatch.test +++ b/tests/pmatch.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/psyntax.test b/tests/psyntax.test index 61f0ff60..64d9cc7e 100755 --- a/tests/psyntax.test +++ b/tests/psyntax.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/quasiquote.test b/tests/quasiquote.test index 6904b8b5..042ea5ac 100755 --- a/tests/quasiquote.test +++ b/tests/quasiquote.test @@ -1,7 +1,6 @@ #! /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 $? diff --git a/tests/read.test b/tests/read.test index 25dd9faf..1b470f8a 100755 --- a/tests/read.test +++ b/tests/read.test @@ -1,7 +1,7 @@ #! /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 $? !# diff --git a/tests/record.test b/tests/record.test index 342fbb96..97e9471b 100755 --- a/tests/record.test +++ b/tests/record.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/scm.test b/tests/scm.test index a01465e8..d83f5a3d 100755 --- a/tests/scm.test +++ b/tests/scm.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/srfi-1.test b/tests/srfi-1.test index 451494e2..3778b7ec 100755 --- a/tests/srfi-1.test +++ b/tests/srfi-1.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/srfi-13.test b/tests/srfi-13.test index afa75f54..18c8ff5c 100755 --- a/tests/srfi-13.test +++ b/tests/srfi-13.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/srfi-14.test b/tests/srfi-14.test index ef2ab712..c1be2d3f 100755 --- a/tests/srfi-14.test +++ b/tests/srfi-14.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/srfi-16.test b/tests/srfi-16.test index 957e8d77..f124e67c 100755 --- a/tests/srfi-16.test +++ b/tests/srfi-16.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/srfi-43.test b/tests/srfi-43.test index 70a90012..3fb6da8d 100755 --- a/tests/srfi-43.test +++ b/tests/srfi-43.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/syntax.test b/tests/syntax.test index 7b26f69f..115c76d5 100755 --- a/tests/syntax.test +++ b/tests/syntax.test @@ -1,7 +1,6 @@ #! /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 $? !# diff --git a/tests/vector.test b/tests/vector.test index 84539869..a63acc69 100755 --- a/tests/vector.test +++ b/tests/vector.test @@ -1,7 +1,6 @@ #! /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 $? !#