andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.
This commit is contained in:
Jan Nieuwenhuizen 2018-04-29 18:38:57 +02:00
parent 3e6319058a
commit a937d18c38
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
55 changed files with 955 additions and 2252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored
View File

@ -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

31
GNUmakefile
View File

@ -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

51
build-aux/build-cc.sh Executable file
View File

@ -0,0 +1,51 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
export CC=${CC-gcc}
build-aux/mes-snarf.scm src/gc.c
build-aux/mes-snarf.scm src/lib.c
build-aux/mes-snarf.scm src/math.c
build-aux/mes-snarf.scm src/mes.c
build-aux/mes-snarf.scm src/posix.c
build-aux/mes-snarf.scm src/reader.c
build-aux/mes-snarf.scm src/vector.c
export CPPFLAGS=${CPPFLAGS-"
-D VERSION=\"$VERSION\"
-D MODULEDIR=\"$MODULEDIR\"
-D PREFIX=\"$PREFIX\"
-I src
-I lib
-I include
"}
export CFLAGS=${CFLAGS-"
--std=gnu99
-O0
-g
"}
NOLINK=1 sh build-aux/cc.sh lib/libc-gcc
#NOLINK=1 sh build-aux/cc.sh lib/libc+tcc-gcc
sh build-aux/cc.sh src/mes

38
build-aux/build-guile.sh Executable file
View File

@ -0,0 +1,38 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
export GUILE=${GUILE-$(type -p guile)}
SCM_FILES="
language/c99/compiler.scm
language/c99/info.scm
mes/as-i386.scm
mes/as.scm
mes/bytevectors.scm
mes/elf.scm
mes/guile.scm
mes/M1.scm"
export srcdir=.
export host=$($GUILE -c "(display %host-type)")
cd guile
$GUILE --no-auto-compile -L . -C . -s ../build-aux/compile-all.scm $SCM_FILES

97
build-aux/build-mes.sh Executable file
View File

@ -0,0 +1,97 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
export HEX2=${HEX2-hex2}
export M1=${M1-M1}
export BLOOD_ELF=${BLOOD_ELF-blood-elf}
export MES_SEED=${MES_SEED-../mes-seed}
export MESCC=${MESCC-$(type -p mescc)}
[ -z "$MESCC" ] && MESCC=scripts/mescc
export MES=${MES-$(type -p mes)}
[ -z "$MES" ] && MES=src/mes
if [ -d "$MES_SEED" ]; then
$M1 --LittleEndian --Architecture=1\
-f stage0/x86.M1\
-f $MES_SEED/crt1.M1\
-o lib/crt1.hex2
$M1 --LittleEndian --Architecture=1\
-f stage0/x86.M1\
-f $MES_SEED/libc-mes.M1\
-o lib/libc-mes.hex2
$M1 --LittleEndian --Architecture=1\
-f stage0/x86.M1\
-f $MES_SEED/mes.M1\
-o src/mes.hex2
$BLOOD_ELF\
-f stage0/x86.M1\
-f $MES_SEED/mes.M1\
-f $MES_SEED/libc-mes.M1\
-o src/mes.blood-elf.M1
$M1 --LittleEndian --Architecture=1\
-f src/mes.blood-elf.M1\
-o src/mes.blood-elf.hex2
$HEX2 --LittleEndian --Architecture=1 --BaseAddress=0x1000000\
-f stage0/elf32-header.hex2\
-f lib/crt1.hex2\
-f lib/libc-mes.hex2\
-f src/mes.hex2\
-f src/mes.blood-elf.hex2\
--exec_enable\
-o src/mes.seed-out
cp src/mes.seed-out src/mes
$M1 --LittleEndian --Architecture=1 -f\
stage0/x86.M1\
-f $MES_SEED/libc+tcc-mes.M1\
-o src/libc+tcc-mes.hex2
fi
[ -n "$SEED" ] && exit 0
export GUILE=src/mes
export MES_ARENA=${MES_ARENA-30000000}
sh build-aux/mes-snarf.scm --mes src/gc.c
sh build-aux/mes-snarf.scm --mes src/lib.c
sh build-aux/mes-snarf.scm --mes src/math.c
sh build-aux/mes-snarf.scm --mes src/mes.c
sh build-aux/mes-snarf.scm --mes src/posix.c
sh build-aux/mes-snarf.scm --mes src/reader.c
sh build-aux/mes-snarf.scm --mes src/vector.c
export PREPROCESS=1
NOLINK=1 sh build-aux/cc-mes.sh lib/crt1
NOLINK=1 sh build-aux/cc-mes.sh lib/mini-libc-mes
NOLINK=1 sh build-aux/cc-mes.sh lib/libc-mes
NOLINK=1 sh build-aux/cc-mes.sh lib/libc+tcc-mes
# sh build-aux/cc-mes.sh scaffold/main
# sh build-aux/cc-mes.sh scaffold/hello
# sh build-aux/cc-mes.sh scaffold/argv
# sh build-aux/cc-mes.sh scaffold/malloc
##sh build-aux/cc-mes.sh scaffold/micro-mes
##sh build-aux/cc-mes.sh scaffold/tiny-mes
# sh build-aux/cc-mes.sh scaffold/mini-mes
sh build-aux/cc-mes.sh src/mes
# FIXME: broken
# cp src/mes.mes-out src/mes

71
build-aux/build-mlibc.sh Executable file
View File

@ -0,0 +1,71 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
export CC32=${CC32-$(type -p i686-unknown-linux-gnu-gcc)}
build-aux/mes-snarf.scm --mes src/gc.c
build-aux/mes-snarf.scm --mes src/lib.c
build-aux/mes-snarf.scm --mes src/math.c
build-aux/mes-snarf.scm --mes src/mes.c
build-aux/mes-snarf.scm --mes src/posix.c
build-aux/mes-snarf.scm --mes src/reader.c
build-aux/mes-snarf.scm --mes src/vector.c
build-aux/mes-snarf.scm src/gc.c
build-aux/mes-snarf.scm src/lib.c
build-aux/mes-snarf.scm src/math.c
build-aux/mes-snarf.scm src/mes.c
build-aux/mes-snarf.scm src/posix.c
build-aux/mes-snarf.scm src/reader.c
build-aux/mes-snarf.scm src/vector.c
export CPPFLAGS=${CPPFLAGS-"
-D VERSION=\"$VERSION\"
-D MODULEDIR=\"$MODULEDIR\"
-D PREFIX=\"$PREFIX\"
-I src
-I lib
-I include
"}
export C32FLAGS=${C32FLAGS-"
--std=gnu99
-O0
-fno-stack-protector
-g
-m32
-nostdinc
-nostdlib
"}
NOLINK=1 sh build-aux/cc-mlibc.sh lib/crt1
NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-gcc
NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc+tcc-gcc
sh build-aux/cc-mlibc.sh scaffold/main
sh build-aux/cc-mlibc.sh scaffold/hello
sh build-aux/cc-mlibc.sh scaffold/argv
sh build-aux/cc-mlibc.sh scaffold/malloc
sh build-aux/cc-mlibc.sh scaffold/micro-mes
sh build-aux/cc-mlibc.sh scaffold/tiny-mes
sh build-aux/cc-mlibc.sh scaffold/mini-mes
sh build-aux/cc-mlibc.sh src/mes

88
build-aux/cc-mes.sh Executable file
View File

@ -0,0 +1,88 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
export HEX2=${HEX2-hex2}
export M1=${M1-M1}
export BLOOD_ELF=${BLOOD_ELF-blood-elf}
export MES_SEED=${MES_SEED-../mes-seed}
export MESCC=${MESCC-$(type -p mescc)}
[ -z "$MESCC" ] && MESCC=scripts/mescc
export MES=${MES-$(type -p mes)}
[ -z "$MES" ] && MES=src/mes
CPPFLAGS=${CPPFLAGS-"
-D VERSION=\"$VERSION\"
-D MODULEDIR=\"$MODULEDIR\"
-D PREFIX=\"$PREFIX\"
-I src
-I lib
-I include
"}
MESCCLAGS=${MESCCFLAGS-"
"}
c=$1
if [ -n "$PREPROCESS" ]; then
sh -x $MESCC\
-E\
$CPPFLAGS\
$MESCCFLAGS\
-o "$c".E\
"$c".c
sh -x $MESCC\
-c\
-o "$c".M1\
"$c".E
else
sh -x $MESCC\
-c\
$CPPFLAGS\
$MESCCFLAGS\
-o "$c".M1\
"$c".c
fi
$M1 --LittleEndian --Architecture=1\
-f stage0/x86.M1\
-f "$c".M1\
-o "$c".hex2
if [ -z "$NOLINK" ]; then
$BLOOD_ELF\
-f stage0/x86.M1\
-f "$c".M1\
-f lib/libc-mes.M1\
-o "$c".blood-elf-M1
$M1 --LittleEndian --Architecture=1\
-f "$c".blood-elf-M1\
-o "$c".blood-elf-hex2
$HEX2 --LittleEndian --Architecture=1 --BaseAddress=0x1000000\
-f stage0/elf32-header.hex2\
-f lib/crt1.hex2\
-f lib/libc-mes.hex2\
-f "$c".hex2\
-f "$c".blood-elf-hex2\
--exec_enable\
-o "$c".mes-out
fi

59
build-aux/cc-mlibc.sh Executable file
View File

@ -0,0 +1,59 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
CPPFLAGS=${CPPFLAGS-"
-D VERSION=\"$VERSION\"
-D MODULEDIR=\"$MODULEDIR\"
-D PREFIX=\"$PREFIX\"
-I src
-I lib
-I include
"}
C32FLAGS=${C32FLAGS-"
--std=gnu99
-O0
-fno-builtin
-fno-stack-protector
-g
-m32
-nostdinc
-nostdlib
"}
c=$1
$CC32\
-c\
$CPPFLAGS\
$C32FLAGS\
-o "$c".mlibc-o\
"$c".c
if [ -z "$NOLINK" ]; then
$CC32\
$C32FLAGS\
-o "$c".mlibc-out\
lib/crt1.mlibc-o\
"$c".mlibc-o\
lib/libc-gcc.mlibc-o
fi

54
build-aux/cc.sh Executable file
View File

@ -0,0 +1,54 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
CPPFLAGS=${CPPFLAGS-"
-D VERSION=\"$VERSION\"
-D MODULEDIR=\"$MODULEDIR\"
-D PREFIX=\"$PREFIX\"
-I src
-I lib
-I include
"}
CFLAGS=${CFLAGS-"
--std=gnu99
-O0
-g
"}
c=$1
$CC\
-c\
$CPPFLAGS\
$CFLAGS\
-D POSIX=1\
-o "$c".gcc-o\
"$c".c
if [ -z "$NOLINK" ]; then
$CC\
$CFLAGS\
-o "$c".gcc-out\
"$c".gcc-o\
lib/libc-gcc.gcc-o
fi

0
check-boot.sh → build-aux/check-boot.sh
View File

237
build-aux/check-mescc.sh Executable file
View File

File diff suppressed because one or more lines are too long

4
build-aux/mes-snarf.scm
View File

@ -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 <file> (make-file name content)
file?
(name file.name)
(content file.content))
(define-record-type function (make-function name formals annotation)
(define-record-type <function> (make-function name formals annotation)
function?
(name function.name)
(formals function.formals)

37
build-aux/test.sh Executable file
View File

@ -0,0 +1,37 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
t=${1-scaffold/tests/t}
#rm -f "$t".i686-unknown-linux-gnu-out
rm -f "$t".mes-out
sh build-aux/cc-mes.sh "$t"
r=0
set +e
"$t".mes-out | tee "$t".stdout
m=$?
[ $m = $r ]
if [ -f "$t".expect ]; then
diff -u "$t".expect "$t".stdout;
fi

71
build.sh
View File

@ -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

141
check-mescc.sh
View File

@ -1,141 +0,0 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
export MES=${MES-src/mes}
export MESCC=${MESCC-scripts/mescc}
#export MES_ARENA=${MES_ARENA-200000000} > 12GB mem
GUILE=${GUILE-guile}
MES=${MES-src/mes}
M1=${M1-M1}
HEX2=${HEX2-hex2}
MES_PREFIX=${MES_PREFIX-.}
# $MESCC -E -o lib/crt1.E lib/crt1.c
# $MESCC -c -o lib/crt1.M1 lib/crt1.E
# $M1 --LittleEndian --Architecture=1 \
# -f stage0/x86.M1\
# -f lib/crt1.M1\
# > lib/crt1.hex2
# $MESCC -E -o lib/libc-mes.E lib/libc-mes.c
# $MESCC -c -o lib/libc-mes.M1 lib/libc-mes.E
# $M1 --LittleEndian --Architecture=1\
# -f stage0/x86.M1\
# -f lib/libc-mes.M1\
# > lib/libc-mes.hex2
tests="
t
00-exit-0
01-return-0
02-return-1
03-call
04-call-0
05-call-1
06-call-!1
10-if-0
11-if-1
12-if-==
13-if-!=
14-if-goto
15-if-!f
16-if-t
20-while
21-char[]
22-while-char[]
23-pointer
30-strlen
31-eputs
32-compare
33-and-or
34-pre-post
35-compare-char
36-compare-arithmetic
37-compare-assign
38-compare-call
40-if-else
41-?
42-goto-label
43-for-do-while
44-switch
45-void-call
50-assert
51-strcmp
52-itoa
53-strcpy
54-argv
60-math
61-array
63-struct-cell
64-make-cell
65-read
70-printf
71-struct-array
72-typedef-struct-def
73-union
74-multi-line-string
75-struct-union
76-pointer-arithmetic
77-pointer-assign
78-union-struct
79-int-array
7a-struct-char-array
7b-struct-int-array
7c-dynarray
7d-cast-char
7e-struct-array-access
7f-struct-pointer-arithmetic
7g-struct-byte-word-field
7h-struct-assign
7i-struct-struct
7j-strtoull
7k-for-each-elem
7l-struct-any-size-array
7m-struct-char-array-assign
7n-struct-struct-array
80-setjmp
81-qsort
82-define
"
if [ ! -x ./i686-unknown-linux-gnu-tcc ]; then
tests=$(echo "$tests" | grep -Ev "02-return-1|05-call-1|80-setjmp|81-qsort")
fi
set +e
fail=0
total=0
for t in $tests; do
sh test.sh "$t" &> scaffold/tests/$t.log
r=$?
total=$((total+1))
if [ $r = 0 ]; then
echo $t: [OK]
else
echo $t: [FAIL]
fail=$((fail+1))
fi
done
if [ $fail != 0 ]; then
echo FAILED: $fail/$total
exit 1
else
echo PASS: $total
fi

6
check.sh
View File

@ -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

546
guile/guix/make.scm
View File

@ -1,546 +0,0 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; make
;;; Code:
(define-module (guix make)
#:use-module (ice-9 curried-definitions)
#:use-module (ice-9 format)
#:use-module (ice-9 optargs)
#:use-module (ice-9 popen)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (guix records)
#:use-module (guix shell-utils)
#:export (base-name
build
check
clean
group
install
target-prefix?
check-target?
install-target?
cpp.mescc
compile.mescc
compile.gcc
ld
bin.mescc
bin.gcc
snarf
m1.as
crt1.mlibc-o
libc-gcc.mlibc-o
libc+tcc-gcc.mlibc-o
add-target
get-target
conjoin
system**
target-file-name
method
target
store
target-inputs
method-name
assert-gulp-pipe*
PATH-search-path
%MESCC
%HEX2
%M1
%targets
%status
%version
%prefix
%datadir
%docdir
%moduledir
%guiledir
%godir))
(define %status 0)
(define %targets '())
(define %store-dir ".store")
(mkdir-p %store-dir)
(define %command-log (open-output-file "script"))
(define (base-name file-name suffix)
(string-drop-right file-name (string-length suffix)))
(define (conjoin . predicates)
(lambda (. arguments)
(every (cut apply <> arguments) predicates)))
(define (system** . command)
(format %command-log "~a\n" (string-join command " "))
(unless (zero? (apply system* command))
(format (current-error-port) "FAILED:~s\n" command)
(exit 1)))
(define (gulp-pipe* . command)
(let* ((port (apply open-pipe* (cons OPEN_READ command)))
(foo (set-port-encoding! port "ISO-8859-1"))
(output (read-string port))
(status (close-pipe port)))
(format %command-log "~a\n" (string-join command " "))
(values output status)))
(define (assert-gulp-pipe* . command)
(receive (output status)
(apply gulp-pipe* command)
(if (zero? status) (string-trim-right output #\newline)
(error (format #f "pipe failed: ~d ~s"
(or (status:exit-val status)
(status:term-sig status)) command)))))
(define-record-type* <method>
method make-method
method?
(name method-name)
(build method-build (default (lambda _ #t)))
(inputs method-inputs (default (list))))
(define-record-type* <target>
target make-target
target?
(file-name target-file-name (default #f)) ; string
(file-names target-file-names (default '())) ; (string)
(hash target-hash (default #f)) ; string
(method target-method (default method-file)) ; <method>
(inputs target-inputs (default (list))) ; list
; For check targets
(baseline target-baseline (default #f)) ; string: file-name
(exit target-exit (default #f)) ; number
(signal target-signal (default #f))) ; number
(define method-file (method (name "FILE")))
(define method-check
(method (name "CHECK")
(build (lambda (o t)
(let* ((inputs (target-inputs t))
(file-name (target-file-name (build (car inputs))))
(run file-name)
(baseline (target-baseline t))
(exit (target-exit t))
(signal (target-signal t))
(log (string-append file-name "-check.log")))
(format (current-error-port) " CHECK\t~a" (basename file-name))
(receive (output result)
;; FIXME: quiet MES tests are not fun
(if (string-prefix? "tests/" run) (values #f (system* run "arg1" "arg2" "arg3" "arg4" "arg5"))
(gulp-pipe* run "arg1" "arg2" "arg3" "arg4" "arg5"))
(if (file-exists? log) (delete-file log))
(if (or baseline (and output (not (string-null? output)))) (with-output-to-file log (lambda _ (display output))))
(if baseline (set! result (system* "diff" "-bu" baseline log)))
(let ((status (if (string? result) 0
(or (status:term-sig result) (status:exit-val result)))))
(if (file-exists? log) (store #:add-file log))
(format (current-error-port) "\t[~a]\n"
(if (or (and signal (= status signal))
(and exit (= status exit))) "OK"
(begin (set! %status 1) "FAIL"))))))))))
(define %version (or (getenv "VERSION") "git"))
(define %prefix (or (getenv "PREFIX") ""))
(define %datadir "share/mes")
(define %docdir "share/doc/mes")
(define %moduledir (string-append %datadir "/module"))
(define %guiledir (string-append "share/guile/site/" (effective-version)))
(define %godir (string-append "lib/guile/" (effective-version) "/site-ccache"))
(define* (method-cp #:key substitutes)
(method (name "INSTALL")
(build (lambda (o t)
(let ((file-name (target-file-name t)))
(mkdir-p (dirname file-name))
(format (current-error-port) " INSTALL\t~a\n" file-name)
(copy-file ((compose target-file-name car target-inputs) t) file-name)
(if substitutes
(begin
(substitute* file-name
(("module/") (string-append %prefix "/" %moduledir "/"))
(("@DATADIR@") (string-append %prefix "/" %datadir "/"))
(("@DOCDIR@") (string-append %prefix "/" %docdir "/"))
(("@GODIR@") (string-append %prefix "/" %godir "/"))
(("@GUILEDIR@") (string-append %prefix "/" %guiledir "/"))
(("@MODULEDIR@") (string-append %prefix "/" %moduledir "/"))
(("@PREFIX@") (string-append %prefix "/"))
(("@VERSION@") %version)))))))))
(define (hash-target o)
(if (find (negate identity) (target-inputs o))
(format (current-error-port) "invalid inputs[~s]: ~s\n" (target-file-name o) (target-inputs o)))
(let ((inputs (target-inputs o)))
(if (null? inputs) (or (target-hash o) (target-hash (store #:add o)))
(let ((input-shas (map hash-target inputs)))
(and (every identity input-shas)
(let ((method (target-method o)))
(string-hash (format #f "~s" (cons* (target-file-name o)
(method-build method)
(map target-hash (method-inputs method))
input-shas)))))))))
(define (string-hash o)
(number->string (hash o (expt 2 31))))
(define (file-hash o)
(string-hash (with-input-from-file o read-string)))
(define (store-file-name o)
(string-append %store-dir "/" (if (string? o) o
(target-hash o))))
(define (link-or-cp existing-file new-file)
(catch #t
(lambda _ (link existing-file new-file))
(lambda _ (copy-file existing-file new-file))))
(define (assert-link existing-file new-file)
(if (not (file-exists? new-file)) (link-or-cp existing-file new-file)))
(define store
(let ((*store* '()))
(define (prune? o)
(let ((t (cdr o)))
(pair? (target-inputs t))))
(define ((file-name? file-name) o)
(let ((t (cdr o)))
(equal? (target-file-name t) (target-file-name file-name))))
(lambda* (#:key add add-file delete get key print prune)
(cond ((and add key) (let ((value (target (inherit add) (hash key))))
(set! *store* (assoc-set! (filter (negate (file-name? add)) *store*) key value))
(let ((file-name (target-file-name value)))
(if (and file-name (file-exists? file-name))
(assert-link file-name (store-file-name value))))
value))
(add (let ((key (if (null? (target-inputs add)) (file-hash (target-file-name add))
(hash-target add))))
(if (not key) (error "store: no hash for:" add))
(store #:add add #:key key)))
(add-file
(or (and=> (find (lambda (t) (equal? (target-file-name t) add-file)) (map cdr *store*))
(compose (cut store #:get <>) target-hash))
(and (file-exists? add-file)
(store #:add (target (file-name add-file))))
(error (format #f "store add-file: no such file: ~s\n" add-file))))
((and get key)
(or (assoc-ref *store* key)
(let ((store-file (store-file-name key))
(file-name (target-file-name get)))
(and (file-exists? store-file)
(if (file-exists? file-name) (delete-file file-name))
(link-or-cp store-file file-name)
(store #:add get #:key key)))))
(get (assoc-ref *store* get))
(delete (and (assoc-ref *store* delete)
(set! *store* (filter (lambda (e) (not (equal? (car e) delete))) *store*))))
(print (pretty-print (map (lambda (e) (cons (target-file-name (cdr e)) (car e))) *store*)))
((eq? prune 'file-system)
(set! *store* (filter prune? *store*)))
(else (error "store: dunno"))))))
(define (build o)
(let ((hash (hash-target o)))
(or (and hash (store #:get o #:key hash))
(begin
;;(format (current-error-port) "must rebuild hash=~s\n" hash)
(for-each build (target-inputs o))
(let ((method (target-method o)))
((method-build method) method o))
(store #:add o #:key hash)))))
(define* (check name #:key baseline (exit 0) (signal #f) (dependencies '()))
(target (file-name (string-append "check-" name))
(method method-check)
(inputs (cons (get-target name) dependencies))
(baseline baseline)
(exit exit)
(signal signal)))
(define* (install name #:key (dir (dirname name)) (installed-name (basename name)) (prefix %prefix) substitutes (dependencies '()))
(target (file-name (string-append prefix "/" dir "/" installed-name))
(method (method-cp #:substitutes substitutes))
(inputs (cons (or (get-target name)
(store #:add-file name)) dependencies))))
(define* (group name #:key (dependencies '()))
(target (file-name name)
(inputs (map get-target dependencies))))
(define (target->input-files o)
(let ((inputs (target-inputs o)))
(if (null? inputs) '()
(append (cons (target-file-name o) (target-file-names o)) (append-map target->input-files inputs)))))
(define* (clean #:optional targets)
(for-each
delete-file
(filter file-exists? (delete-duplicates (append-map (cut target->input-files <>) (or targets %targets))))))
(define (tree o)
(let ((inputs (target-inputs o)))
(if (null? inputs) o
(cons o (append (map tree inputs) (map tree (method-inputs (target-method o))))))))
(define (verbose fmt . o)
;;(apply format (cons* (current-error-port) fmt o))
#t
)
(define* (PATH-search-path name #:key (default name))
(or (search-path (string-split (getenv "PATH") #\:) name)
(and (format (current-error-port) "warning: not found: ~a\n" name)
default)))
(define %CC (or (getenv "CC") (PATH-search-path "gcc")))
(define %CC32 (or (getenv "CC32")
(PATH-search-path "i686-unknown-linux-gnu-gcc" #:default #f)
(and (format (current-error-port) "warning: CC32 not found, trying gcc -m32")
%CC)))
(define %C-FLAGS
'("--std=gnu99"
"-O0"
"-g"
"-D"
"POSIX=1"
"-I" "src"
"-I" "lib"
"-I" "include"
"--include=lib/libc-gcc.c"))
(define %C32-FLAGS
'("--std=gnu99"
"-O0"
"-fno-stack-protector"
"-g"
"-m32"
"-I" "src"
"-I" "lib"
"-I" "include"))
(define* (CC.gcc #:key (libc #t) (cc (if (eq? libc #t) %CC %CC32)) (c-flags (if (eq? libc #t) %C-FLAGS %C32-FLAGS)) (defines '()) (includes '()))
(method (name "CC.gcc")
(build (lambda (o t)
(let* ((input-files (map target-file-name (target-inputs t)))
(command `(,cc
"-c"
,@(append-map (cut list "-D" <>) defines)
,@(append-map (cut list "-I" <>) includes)
,@(if (eq? libc #t) '() '("-nostdinc" "-fno-builtin"))
,@c-flags
"-o" ,(target-file-name t)
,@(filter (cut string-suffix? ".c" <>) input-files))))
(format (current-error-port) " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
(apply system** command))))))
(define* (CPP.mescc #:key (cc %MESCC) (defines '()) (includes '()))
(method (name "CPP.mescc")
(build (lambda (o t)
(let ((input-files (map target-file-name (target-inputs t))))
(format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
(apply system**
`(,cc
"-E"
,@(append-map (cut list "-D" <>) defines)
,@(append-map (cut list "-I" <>) includes)
"-o" ,(target-file-name t)
,@input-files)))))))
(define %MESCC "scripts/mescc")
(define* (CC.mescc #:key (cc %MESCC))
(method (name "CC.mescc")
(build (lambda (o t)
(let ((input-files (map target-file-name (target-inputs t))))
(format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
(setenv "MES" "guile")
(apply system**
`("scripts/mescc" "-c"
"-o" ,(target-file-name t)
,@input-files))
(unsetenv "MES"))))
(inputs (list (store #:add-file "guile/language/c99/info.go")
(store #:add-file "guile/language/c99/compiler.go")
(store #:add-file "guile/mes/as-i386.go")
(store #:add-file "guile/mes/as.go")
(store #:add-file "guile/mes/elf.go")
(store #:add-file "guile/mes/bytevectors.go")
(store #:add-file "guile/mes/M1.go")
(store #:add-file "guile/mes/guile.go")))))
(define %M1 (or (PATH-search-path "M1" #:default #f)
(PATH-search-path "M0" #:default #f) ; M1 is in unreleased mescc-tools 0.2
(and (format (current-error-port) "error: no macro assembler found, please install mescc-tools\n")
(exit 1))))
(define %M0-FLAGS
'("--LittleEndian"))
(define %M1-FLAGS
'("--LittleEndian"
"--Architecture=1"))
(if (equal? (basename %M1) "M0")
(set! %M1-FLAGS %M0-FLAGS))
(define* (M1.as #:key (m1 %M1) (m1-flags %M1-FLAGS))
(method (name "M1")
(build (lambda (o t)
(let* ((input-files (map target-file-name (target-inputs t)))
(input-files (filter (lambda (f) (string-suffix? "M1" f))
input-files)))
(format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
(with-output-to-file (target-file-name t)
(lambda _
(display
(apply assert-gulp-pipe*
`(,m1
"-f"
"stage0/x86.M1"
,@(append-map (cut list "-f" <>) input-files)
,@m1-flags)))
(newline))))))
(inputs (list (store #:add-file "stage0/x86.M1")))))
(define* (LINK.gcc #:key (cc %CC) (libc #t) (c-flags (if (eq? libc #t) %C-FLAGS %C32-FLAGS)) (crt1 #f))
(method (name "LINK.gcc")
(build (lambda (o t)
(let* ((input-files (map target-file-name (target-inputs t)))
(command `(,cc
,@c-flags
,@(if (eq? libc #t) '() '("-nostdlib"))
"-o"
,(target-file-name t)
,@(if crt1 (list (target-file-name crt1))'())
,@input-files
,@(cond ((eq? libc #t) '())
(libc (list (target-file-name libc)))
(else '())))))
(format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
(apply system** command))))))
(define SNARF "build-aux/mes-snarf.scm")
(define (SNARF.mes mes?)
(method (name "SNARF.mes")
(build (lambda (o t)
(let* ((input-files (map target-file-name (target-inputs t)))
(command `(,SNARF
,@(if mes? '("--mes") '())
,@input-files)))
(format #t " ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
(apply system** command))))))
(define* (cpp.mescc input-file-name #:key (cc %MESCC) (defines '()) (includes '()) (dependencies '()))
(let* ((c-target (target (file-name input-file-name)))
(base-name (base-name input-file-name ".c"))
(suffix ".E")
(target-file-name (string-append base-name suffix)))
(target (file-name target-file-name)
(inputs (cons c-target dependencies))
(method (CPP.mescc #:cc cc #:defines defines #:includes includes)))))
(define* (compile.gcc input-file-name #:key (libc #t) (cc (if (eq? libc #t) %CC %CC32)) (defines '()) (includes '()) (dependencies '()))
(let* ((base-name (base-name input-file-name ".c"))
(cross (if (eq? libc #t) "" "mlibc-"))
(suffix (string-append "." cross "o"))
(target-file-name (string-append base-name suffix))
(c-target (target (file-name input-file-name))))
(target (file-name target-file-name)
(inputs (cons c-target dependencies))
(method (CC.gcc #:cc cc #:libc libc #:defines defines #:includes includes)))))
(define* (compile.mescc input-file-name #:key (cc %MESCC) (defines '()) (includes '()) (dependencies '()))
(let* ((base-name (base-name input-file-name ".c"))
(suffix ".M1")
(target-file-name (string-append base-name suffix))
(E-target (cpp.mescc input-file-name #:cc cc #:defines defines #:includes includes #:dependencies dependencies)))
(target (file-name target-file-name)
(inputs `(,E-target))
(method (CC.mescc #:cc cc)))))
(define* (m1.as input-file-name #:key (cc %MESCC) (m1 %M1) (defines '()) (includes '()) (dependencies '()))
(let* ((base-name (base-name input-file-name ".c"))
;;(foo (format (current-error-port) "m1.as[~s .m1] base=~s\n" input-file-name base-name))
(suffix ".hex2")
(target-file-name (string-append base-name suffix))
(m1-target (compile.mescc input-file-name #:cc cc #:defines defines #:includes includes #:dependencies dependencies)))
(target (file-name target-file-name)
(inputs `(,m1-target))
(method (M1.as #:m1 m1)))))
(define* (bin.gcc input-file-name #:key (libc #t) (crt1 (if (eq? libc #t) #f crt1.mlibc-o)) (cc (if (eq? libc #t) %CC %CC32)) (dependencies '()) (defines '()) (includes '()))
(and cc
(let* ((base-name (base-name input-file-name ".c"))
(suffix (if (eq? libc #t) ".gcc" ".mlibc-gcc"))
(target-file-name (string-append base-name suffix))
(o-target (compile.gcc input-file-name #:cc cc #:libc libc #:defines defines #:includes includes #:dependencies dependencies)))
(target (file-name target-file-name)
(inputs (list o-target))
(method (LINK.gcc #:cc cc #:libc libc #:crt1 crt1))))))
(define* (snarf input-file-name #:key (dependencies '()) (mes? #t))
(let* ((base-name (base-name input-file-name ".c"))
(suffixes '(".h" ".i" ".environment.i" ".symbol-names.i" ".symbols.i" ".symbols.h"))
(suffixes (if mes? (map (cut string-append ".mes" <>) suffixes) suffixes))
(target-file-names (map (cut string-append base-name <>) suffixes))
(snarf-target (target (file-name input-file-name))))
(target (file-name (car target-file-names))
(file-names (cdr target-file-names))
(inputs (cons snarf-target dependencies))
;;(inputs (list snarf-target))
(method (SNARF.mes mes?)))))
(define ((target-prefix? prefix) o)
(string-prefix? prefix (target-file-name o)))
(define (check-target? o)
(and o ((target-prefix? "check-") o)))
(define (install-target? o)
(and o ((target-prefix? (or (getenv "PREFIX") "/")) o)))
(define (add-target o)
(and o (set! %targets (append %targets (list o))))
o)
(define (get-target o)
(if (target? o) o
(find (lambda (t) (equal? (target-file-name t) o)) %targets)))
(define crt1.mlibc-o (compile.gcc "lib/crt1.c" #:libc #f))
(define libc-gcc.mlibc-o (compile.gcc "lib/libc-gcc.c" #:libc #f))
(define libc+tcc-gcc.mlibc-o (compile.gcc "lib/libc+tcc-gcc.c" #:libc #f))

378
guile/guix/records.scm
View File

@ -1,378 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix records)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:export (define-record-type*
alist->record
object->fields
recutils->alist))
;;; Commentary:
;;;
;;; Utilities for dealing with Scheme records.
;;;
;;; Code:
(define-syntax record-error
(syntax-rules ()
"Report a syntactic error in use of CONSTRUCTOR."
((_ constructor form fmt args ...)
(syntax-violation constructor
(format #f fmt args ...)
form))))
(define (report-invalid-field-specifier name bindings)
"Report the first invalid binding among BINDINGS."
(let loop ((bindings bindings))
(syntax-case bindings ()
(((field value) rest ...) ;good
(loop #'(rest ...)))
((weird _ ...) ;weird!
(syntax-violation name "invalid field specifier" #'weird)))))
(define-syntax make-syntactic-constructor
(syntax-rules ()
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and
expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
fields, and DELAYED is the list of identifiers of delayed fields."
((_ type name ctor (expected ...)
#:thunked thunked
#:delayed delayed
#:innate innate
#:defaults defaults)
(define-syntax name
(lambda (s)
(define (record-inheritance orig-record field+value)
;; Produce code that returns a record identical to ORIG-RECORD,
;; except that values for the FIELD+VALUE alist prevail.
(define (field-inherited-value f)
(and=> (find (lambda (x)
(eq? f (car (syntax->datum x))))
field+value)
car))
;; Make sure there are no unknown field names.
(let* ((fields (map (compose car syntax->datum) field+value))
(unexpected (lset-difference eq? fields '(expected ...))))
(when (pair? unexpected)
(record-error 'name s "extraneous field initializers ~a"
unexpected)))
#`(make-struct/no-tail type
#,@(map (lambda (field index)
(or (field-inherited-value field)
(if (innate-field? field)
(wrap-field-value
field (field-default-value field))
#`(struct-ref #,orig-record
#,index))))
'(expected ...)
(iota (length '(expected ...))))))
(define (thunked-field? f)
(memq (syntax->datum f) 'thunked))
(define (delayed-field? f)
(memq (syntax->datum f) 'delayed))
(define (innate-field? f)
(memq (syntax->datum f) 'innate))
(define (wrap-field-value f value)
(cond ((thunked-field? f)
#`(lambda () #,value))
((delayed-field? f)
#`(delay #,value))
(else value)))
(define default-values
;; List of symbol/value tuples.
(map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'defaults))
(define (field-default-value f)
(car (assoc-ref default-values (syntax->datum f))))
(define (field-bindings field+value)
;; Return field to value bindings, for use in 'let*' below.
(map (lambda (field+value)
(syntax-case field+value ()
((field value)
#`(field
#,(wrap-field-value #'field #'value)))))
field+value))
(syntax-case s (inherit expected ...)
((_ (inherit orig-record) (field value) (... ...))
#`(let* #,(field-bindings #'((field value) (... ...)))
#,(record-inheritance #'orig-record
#'((field value) (... ...)))))
((_ (field value) (... ...))
(let ((fields (map syntax->datum #'(field (... ...)))))
(define (field-value f)
(or (find (lambda (x)
(eq? f (syntax->datum x)))
#'(field (... ...)))
(wrap-field-value f (field-default-value f))))
(let ((fields (append fields (map car default-values))))
(cond ((lset= eq? fields '(expected ...))
#`(let* #,(field-bindings
#'((field value) (... ...)))
(ctor #,@(map field-value '(expected ...)))))
((pair? (lset-difference eq? fields
'(expected ...)))
(record-error 'name s
"extraneous field initializers ~a"
(lset-difference eq? fields
'(expected ...))))
(else
(record-error 'name s
"missing field initializers ~a"
(lset-difference eq?
'(expected ...)
fields)))))))
((_ bindings (... ...))
;; One of BINDINGS doesn't match the (field value) pattern.
;; Report precisely which one is faulty, instead of letting the
;; "source expression failed to match any pattern" error.
(report-invalid-field-specifier 'name
#'(bindings (... ...))))))))))
(define-syntax-rule (define-field-property-predicate predicate property)
"Define PREDICATE as a procedure that takes a syntax object and, when passed
a field specification, returns the field name if it has the given PROPERTY."
(define (predicate s)
(syntax-case s (property)
((field (property values (... ...)) _ (... ...))
#'field)
((field _ properties (... ...))
(predicate #'(field properties (... ...))))
(_ #f))))
(define-syntax define-record-type*
(lambda (s)
"Define the given record type such that an additional \"syntactic
constructor\" is defined, which allows instances to be constructed with named
field initializers, à la SRFI-35, as well as default values. An example use
may look like this:
(define-record-type* <thing> thing make-thing
thing?
(name thing-name (default \"chbouib\"))
(port thing-port
(default (current-output-port)) (thunked))
(loc thing-location (innate) (default (current-source-location))))
This example defines a macro 'thing' that can be used to instantiate records
of this type:
(thing
(name \"foo\")
(port (current-error-port)))
The value of 'name' or 'port' could as well be omitted, in which case the
default value specified in the 'define-record-type*' form is used:
(thing)
The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
actually compute the field's value in the current dynamic extent, which is
useful when referring to fluids in a field's value.
A field can also be marked as \"delayed\" instead of \"thunked\", in which
case its value is effectively wrapped in a (delay …) form.
It is possible to copy an object 'x' created with 'thing' like this:
(thing (inherit x) (name \"bar\"))
This expression returns a new object equal to 'x' except for its 'name'
field and its 'loc' field---the latter is marked as \"innate\", so it is not
inherited."
(define (field-default-value s)
(syntax-case s (default)
((field (default val) _ ...)
(list #'field #'val))
((field _ properties ...)
(field-default-value #'(field properties ...)))
(_ #f)))
(define-field-property-predicate delayed-field? delayed)
(define-field-property-predicate thunked-field? thunked)
(define-field-property-predicate innate-field? innate)
(define (wrapped-field? s)
(or (thunked-field? s) (delayed-field? s)))
(define (wrapped-field-accessor-name field)
;; Return the name (an unhygienic syntax object) of the "real"
;; getter for field, which is assumed to be a wrapped field.
(syntax-case field ()
((field get properties ...)
(let* ((getter (syntax->datum #'get))
(real-getter (symbol-append '% getter '-real)))
(datum->syntax #'get real-getter)))))
(define (field-spec->srfi-9 field)
;; Convert a field spec of our style to a SRFI-9 field spec of the
;; form (field get).
(syntax-case field ()
((name get properties ...)
#`(name
#,(if (wrapped-field? field)
(wrapped-field-accessor-name field)
#'get)))))
(define (thunked-field-accessor-definition field)
;; Return the real accessor for FIELD, which is assumed to be a
;; thunked field.
(syntax-case field ()
((name get _ ...)
(with-syntax ((real-get (wrapped-field-accessor-name field)))
#'(define-inlinable (get x)
;; The real value of that field is a thunk, so call it.
((real-get x)))))))
(define (delayed-field-accessor-definition field)
;; Return the real accessor for FIELD, which is assumed to be a
;; delayed field.
(syntax-case field ()
((name get _ ...)
(with-syntax ((real-get (wrapped-field-accessor-name field)))
#'(define-inlinable (get x)
;; The real value of that field is a promise, so force it.
(force (real-get x)))))))
(syntax-case s ()
((_ type syntactic-ctor ctor pred
(field get properties ...) ...)
(let* ((field-spec #'((field get properties ...) ...))
(thunked (filter-map thunked-field? field-spec))
(delayed (filter-map delayed-field? field-spec))
(innate (filter-map innate-field? field-spec))
(defaults (filter-map field-default-value
#'((field properties ...) ...))))
(with-syntax (((field-spec* ...)
(map field-spec->srfi-9 field-spec))
((thunked-field-accessor ...)
(filter-map (lambda (field)
(and (thunked-field? field)
(thunked-field-accessor-definition
field)))
field-spec))
((delayed-field-accessor ...)
(filter-map (lambda (field)
(and (delayed-field? field)
(delayed-field-accessor-definition
field)))
field-spec)))
#`(begin
(define-record-type type
(ctor field ...)
pred
field-spec* ...)
thunked-field-accessor ...
delayed-field-accessor ...
(make-syntactic-constructor type syntactic-ctor ctor
(field ...)
#:thunked #,thunked
#:delayed #,delayed
#:innate #,innate
#:defaults #,defaults))))))))
(define* (alist->record alist make keys
#:optional (multiple-value-keys '()))
"Apply MAKE to the values associated with KEYS in ALIST. Items in KEYS that
are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
times in ALIST, and thus their value is a list."
(let ((args (map (lambda (key)
(if (member key multiple-value-keys)
(filter-map (match-lambda
((k . v)
(and (equal? k key) v)))
alist)
(assoc-ref alist key)))
keys)))
(apply make args)))
(define (object->fields object fields port)
"Write OBJECT (typically a record) as a series of recutils-style fields to
PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
(let loop ((fields fields))
(match fields
(()
object)
(((field . get) rest ...)
(format port "~a: ~a~%" field (get object))
(loop rest)))))
(define %recutils-field-charset
;; Valid characters starting a recutils field.
;; info "(recutils) Fields"
(char-set-union char-set:upper-case
char-set:lower-case
(char-set #\%)))
(define (recutils->alist port)
"Read a recutils-style record from PORT and return it as a list of key/value
pairs. Stop upon an empty line (after consuming it) or EOF."
(let loop ((line (read-line port))
(result '()))
(cond ((eof-object? line)
(reverse result))
((string-null? line)
(if (null? result)
(loop (read-line port) result) ; leading space: ignore it
(reverse result))) ; end-of-record marker
(else
;; Now check the first character of LINE, since that's what the
;; recutils manual says is enough.
(let ((first (string-ref line 0)))
(cond
((char-set-contains? %recutils-field-charset first)
(let* ((colon (string-index line #\:))
(field (string-take line colon))
(value (string-trim (string-drop line (+ 1 colon)))))
(loop (read-line port)
(alist-cons field value result))))
((eqv? first #\#) ;info "(recutils) Comments"
(loop (read-line port) result))
((eqv? first #\+) ;info "(recutils) Fields"
(let ((new-line (if (string-prefix? "+ " line)
(string-drop line 2)
(string-drop line 1))))
(match result
(((field . value) rest ...)
(loop (read-line port)
`((,field . ,(string-append value "\n" new-line))
,@rest))))))
(else
(error "unmatched line" line))))))))
;;; records.scm ends here

225
guile/guix/shell-utils.scm
View File

@ -1,225 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix shell-utils)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:export (dump-port
mkdir-p
with-directory-excursion
substitute
substitute*))
;;;
;;; Directories.
;;;
(define (mkdir-p dir)
"Create directory DIR and all its ancestors."
(define absolute?
(string-prefix? "/" dir))
(define not-slash
(char-set-complement (char-set #\/)))
(let loop ((components (string-tokenize dir not-slash))
(root (if absolute?
""
".")))
(match components
((head tail ...)
(let ((path (string-append root "/" head)))
(catch 'system-error
(lambda ()
(mkdir path)
(loop tail path))
(lambda args
(if (= EEXIST (system-error-errno args))
(loop tail path)
(apply throw args))))))
(() #t))))
(define-syntax-rule (with-directory-excursion dir body ...)
"Run BODY with DIR as the process's current directory."
(let ((init (getcwd)))
(dynamic-wind
(lambda ()
(chdir dir))
(lambda ()
body ...)
(lambda ()
(chdir init)))))
(define* (dump-port in out
#:key (buffer-size 16384)
(progress (lambda (t k) (k))))
"Read as much data as possible from IN and write it to OUT, using chunks of
BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
transferred and the continuation of the transfer as a thunk."
(define buffer
(make-bytevector buffer-size))
(define (loop total bytes)
(or (eof-object? bytes)
(let ((total (+ total bytes)))
(put-bytevector out buffer 0 bytes)
(progress total
(lambda ()
(loop total
(get-bytevector-n! in buffer 0 buffer-size)))))))
;; Make sure PROGRESS is called when we start so that it can measure
;; throughput.
(progress 0
(lambda ()
(loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
;;;
;;; 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)))))))

43
install.sh
View File

@ -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

720
make.scm
View File

File diff suppressed because one or more lines are too long

6
module/language/c99/compiler.mes
View File

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

128
scaffold/mini-mes.c
View File

@ -19,6 +19,7 @@
*/
#define MES_MINI 1
//#define HAVE_UNION 1
#if POSIX
#error "POSIX not supported"
#endif
@ -29,9 +30,10 @@
#include <string.h>
#include <mlibc.h>
int ARENA_SIZE = 100000;
int MAX_ARENA_SIZE = 40000000;
int GC_SAFETY = 10000;
int ARENA_SIZE = 200000; // 32b: 2MiB, 64b: 4 MiB
int MAX_ARENA_SIZE = 300000000;
int JAM_SIZE = 20000;
int GC_SAFETY = 2000;
char *g_arena = 0;
typedef int SCM;
@ -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, "<cell:char>",0};
struct scm scm_type_closure = {TSYMBOL, "<cell:closure>",0};
struct scm scm_type_continuation = {TSYMBOL, "<cell:continuation>",0};
struct scm scm_type_function = {TSYMBOL, "<cell:function>",0};
struct scm scm_type_keyword = {TSYMBOL, "<cell:keyword>",0};
struct scm scm_type_macro = {TSYMBOL, "<cell:macro>",0};
struct scm scm_type_number = {TSYMBOL, "<cell:number>",0};
struct scm scm_type_pair = {TSYMBOL, "<cell:pair>",0};
struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
struct scm scm_type_vector = {TSYMBOL, "<cell:vector>",0};
struct scm scm_type_broken_heart = {TSYMBOL, "<cell:broken-heart>",0};
struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
@ -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))
{

12
scripts/mescc
View File

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

10
src/mes.c
View File

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

66
test.sh
View File

@ -1,66 +0,0 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Mes.
#
# Mes is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Mes is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex
t=${1-t}
rm -f "$t".i686-unknown-linux-gnu-out
rm -f "$t".mes-out
M1=${M1-M1}
HEX2=${HEX2-hex2}
MES=${MES-guile}
MESCC=${MESCC-scripts/mescc}
sh $MESCC -E -o scaffold/tests/$t.E scaffold/tests/$t.c
sh $MESCC -c -o scaffold/tests/$t.M1 scaffold/tests/$t.E
$M1 --LittleEndian --Architecture=1\
-f stage0/x86.M1\
-f scaffold/tests/$t.M1\
-o scaffold/tests/$t.hex2
# $MESCC -E -o lib/crt1.E lib/crt1.c
# $MESCC -c -o lib/crt1.M1 lib/crt1.E
# $M1 --LittleEndian --Architecture=1 \
# -f stage0/x86.M1\
# -f lib/crt1.M1\
# -o lib/crt1.hex2
# $MESCC -E -o lib/libc-mes.E lib/libc-mes.c
# $MESCC -c -o lib/libc-mes.M1 lib/libc-mes.E
# $M1 --LittleEndian --Architecture=1\
# -f stage0/x86.M1\
# -f lib/libc-mes.M1\
# -o lib/libc-mes.hex2
$HEX2 --LittleEndian --Architecture=1 --BaseAddress=0x1000000\
-f stage0/elf32-header.hex2\
-f lib/crt1.hex2\
-f lib/libc-mes.hex2\
-f scaffold/tests/$t.hex2\
-f stage0/elf32-footer-single-main.hex2\
-o scaffold/tests/$t.mes-out
chmod +x scaffold/tests/$t.mes-out
r=0
set +e
scaffold/tests/$t.mes-out
m=$?
[ $m = $r ]

2
tests/base.test
View File

@ -1,6 +1,6 @@
#! /bin/sh
# -*-scheme-*-
MES=${MES-$(dirname $0)/../src/mes.gcc}
MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#

2
tests/boot.test
View File

@ -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 $?

3
tests/catch.test
View File

@ -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 $?
!#

3
tests/closure.test
View File

@ -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 $?
!#

3
tests/cwv.test
View File

@ -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 $?
!#

2
tests/display.test
View File

@ -1,6 +1,6 @@
#! /bin/sh
# -*-scheme-*-
MES=${MES-$(dirname $0)/../src/mes.gcc}
MES=${MES-$(dirname $0)/../src/mes}
$MES -s $0
exit $?
!#

3
tests/fluids.test
View File

@ -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 $?
!#

3
tests/getopt-long.test
View File

@ -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 $?
!#

3
tests/guile.test
View File

@ -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 $?
!#

3
tests/let-syntax.test
View File

@ -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 $?
!#

3
tests/let.test
View File

@ -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 $?
!#

3
tests/match.test
View File

@ -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 $?
!#

3
tests/math.test
View File

@ -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 $?
!#

3
tests/module.test
View File

@ -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 $?
!#

3
tests/optargs.test
View File

@ -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 $?
!#

3
tests/peg.test
View File

@ -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 $?
!#

3
tests/pmatch.test
View File

@ -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 $?
!#

3
tests/psyntax.test
View File

@ -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 $?
!#

3
tests/quasiquote.test
View File

@ -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 $?

2
tests/read.test
View File

@ -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 $?
!#

3
tests/record.test
View File

@ -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 $?
!#

3
tests/scm.test
View File

@ -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 $?
!#

3
tests/srfi-1.test
View File

@ -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 $?
!#

3
tests/srfi-13.test
View File

@ -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 $?
!#

3
tests/srfi-14.test
View File

@ -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 $?
!#

3
tests/srfi-16.test
View File

@ -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 $?
!#

3
tests/srfi-43.test
View File

@ -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 $?
!#

3
tests/syntax.test
View File

@ -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 $?
!#

3
tests/vector.test
View File

@ -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 $?
!#