artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Posixify interface.

Browse source 
* module/mescc/compile.mes: Move from language/c99/compiler.mes.
* module/mescc: New module..
* module/mescc/M1.scm: Move from mes/M1.mes.
* module/mescc/as.scm: Likewise.
* module/mescc/bytevectors.scm: Likewise.
* module/mescc/mescc.scm: New file.
* scripts/mescc: Update to new layout and posixy interface.
* GNUmakefile: Likewise.
* build-aux/build-cc.sh: Likewise.
* build-aux/build-guile.sh: Likewise.
* build-aux/build-mes.sh: Likewise.
* build-aux/build-mlibc.sh: Likewise.
* build-aux/cc-mes.sh: Likewise.
* build-aux/cc-mlibc.sh: Likewise.
* build-aux/cc.sh: Likewise.
* build-aux/check-mescc.sh: Likewise.
* build-aux/test.sh: Likewise.
* build.sh: Likewise.
* .gitignore: Update for posixy extensions.
This commit is contained in:
Jan Nieuwenhuizen 2018-05-25 08:05:02 +02:00
parent 2748992551
commit a10c48735d
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
52 changed files with 1024 additions and 987 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
.gitignore vendored
View file

@ -8,12 +8,13 @@
*.0-guile *.0-guile
*.0-hex2 *.0-hex2
*.E *.E
*.M1 *.S
*.o
*.blood-elf
*.gcc *.gcc
*.guile *.guile
*.hex2
*.hex2-o
*.log *.log
*.gcc-o
*.mes-o *.mes-o
*.mes-stdout *.mes-stdout
*.mini-M1 *.mini-M1
@ -32,8 +33,8 @@
/src/*.h /src/*.h
/src/*.i /src/*.i
/src/mes
*.o
/.config.make /.config.make
/.store /.store
/.tarball-version /.tarball-version
@ -59,4 +60,3 @@
/doc/fosdem/fosdem.tex /doc/fosdem/fosdem.tex
/doc/fosdem/fosdem.toc /doc/fosdem/fosdem.toc
/doc/fosdem/fosdem.*vrb /doc/fosdem/fosdem.*vrb

3
AUTHORS
View file

@ -12,9 +12,6 @@ List of imported files
Based on Guile ECMAScript Based on Guile ECMAScript
module/language/c/lexer.mes module/language/c/lexer.mes
Included verbatim from GNU Guix
build-aux/compile-all.scm
Included verbatim from gnulib Included verbatim from gnulib
build-aux/gitlog-to-changelog build-aux/gitlog-to-changelog

2
GNUmakefile
View file

@ -38,7 +38,7 @@ install:
.config.make: ./configure .config.make: ./configure
seed: seed: all-go
cd $(MES_SEED) && git reset --hard HEAD cd $(MES_SEED) && git reset --hard HEAD
MES=$(GUILE) GUILE=$(GUILE) SEED=1 build-aux/build-mes.sh MES=$(GUILE) GUILE=$(GUILE) SEED=1 build-aux/build-mes.sh
cd $(MES_SEED) && MES_PREFIX=$(PWD) ./refresh.sh cd $(MES_SEED) && MES_PREFIX=$(PWD) ./refresh.sh

8
build-aux/build-cc.sh
View file

@ -18,7 +18,11 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex set -e
if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
export CC CFLAGS CPPFLAGS export CC CFLAGS CPPFLAGS
@ -46,7 +50,7 @@ build-aux/mes-snarf.scm src/posix.c
build-aux/mes-snarf.scm src/reader.c build-aux/mes-snarf.scm src/reader.c
build-aux/mes-snarf.scm src/vector.c build-aux/mes-snarf.scm src/vector.c
NOLINK=1 sh build-aux/cc.sh lib/mini-libc-gcc NOLINK=1 sh build-aux/cc.sh lib/libc-mini-gcc
NOLINK=1 sh build-aux/cc.sh lib/libc-gcc NOLINK=1 sh build-aux/cc.sh lib/libc-gcc
NOLINK=1 sh build-aux/cc.sh lib/libc+tcc-gcc NOLINK=1 sh build-aux/cc.sh lib/libc+tcc-gcc

52
build-aux/build-guile.sh
View file

@ -18,23 +18,51 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
export GUILE export GUILE
GUILE=${GUILE-$(command -v guile)} GUILE=${GUILE-$(command -v guile)}
GUILE_TOOLS=${GUILE_TOOLS-$(command -v guile-tools)}
set -e
SCM_FILES=" SCM_FILES="
language/c99/compiler.scm guile/mes/guile.scm
language/c99/info.scm guile/mes/misc.scm
mes/as-i386.scm guile/mes/test.scm
mes/as.scm guile/mescc/M1.scm
mes/bytevectors.scm guile/mescc/as.scm
mes/elf.scm guile/mescc/bytevectors.scm
mes/guile.scm guile/mescc/compile.scm
mes/test.scm guile/mescc/i386/as.scm
mes/M1.scm" guile/mescc/info.scm
guile/mescc/mescc.scm
guile/mescc/preprocess.scm
"
export srcdir=. export srcdir=.
export host=$($GUILE -c "(display %host-type)") export host=$($GUILE -c "(display %host-type)")
cd guile
$GUILE --no-auto-compile -L . -C . -s ../build-aux/compile-all.scm $SCM_FILES #$GUILE --no-auto-compile -L guile -C guile -s build-aux/compile-all.scm $SCM_FILES
for i in $SCM_FILES; do
go=${i%%.scm}.go
if [ $i -nt $go ]; then
echo " GUILEC $i"
$GUILE_TOOLS compile -L guile -L scripts -o $go $i
fi
done
SCRIPTS="
scripts/mescc
"
for i in $SCRIPTS; do
go=${i%%.scm}.go
if [ $i -nt $go ]; then
echo " GUILEC $i"
$GUILE_TOOLS compile -L guile -L scripts -o $go $i
fi
done

48
build-aux/build-mes.sh
View file

@ -18,12 +18,19 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -x if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
export BLOOD_ELF GUILE HEX2 M1 MES MESCC export BLOOD_ELF GUILE HEX2 M1 MES MESCC
export M1FLAGS HEX2FLAGS PREPROCESS export M1FLAGS HEX2FLAGS PREPROCESS
export MES_SEED MES_ARENA export MES_SEED MES_ARENA
GUILE=${GUILE-guile}
if [ -z "$GUILE" -o "$GUILE" = "true" ] || ! command -v $GUILE > /dev/null; then
GUILE=src/mes
fi
HEX2=${HEX2-hex2} HEX2=${HEX2-hex2}
M1=${M1-M1} M1=${M1-M1}
BLOOD_ELF=${BLOOD_ELF-blood-elf} BLOOD_ELF=${BLOOD_ELF-blood-elf}
@ -50,55 +57,58 @@ if [ -d "$MES_SEED" ]; then
$M1FLAGS\ $M1FLAGS\
-f stage0/x86.M1\ -f stage0/x86.M1\
-f $MES_SEED/crt1.M1\ -f $MES_SEED/crt1.M1\
-o lib/crt1.hex2 -o lib/crt1.o
$M1\ $M1\
$M1FLAGS\ $M1FLAGS\
-f stage0/x86.M1\ -f stage0/x86.M1\
-f $MES_SEED/libc-mes.M1\ -f $MES_SEED/libc-mes.M1\
-o lib/libc-mes.hex2 -o lib/libc-mes.o
$M1\ $M1\
--LittleEndian\ --LittleEndian\
--Architecture=1\ --Architecture=1\
-f stage0/x86.M1\ -f stage0/x86.M1\
-f $MES_SEED/mes.M1\ -f $MES_SEED/mes.M1\
-o src/mes.hex2 -o src/mes.o
$BLOOD_ELF\ $BLOOD_ELF\
-f stage0/x86.M1\ -f stage0/x86.M1\
-f $MES_SEED/mes.M1\ -f $MES_SEED/mes.M1\
-f $MES_SEED/libc-mes.M1\ -f $MES_SEED/libc-mes.M1\
-o src/mes.blood-elf.M1 -o src/mes.S.blood-elf
$M1\ $M1\
--LittleEndian\ --LittleEndian\
--Architecture=1\ --Architecture=1\
-f src/mes.blood-elf.M1\ -f src/mes.S.blood-elf\
-o src/mes.blood-elf.hex2 -o src/mes.o.blood-elf
$HEX2\ $HEX2\
$HEX2FLAGS\ $HEX2FLAGS\
-f stage0/elf32-header.hex2\ -f stage0/elf32-header.hex2\
-f lib/crt1.hex2\ -f lib/crt1.o\
-f lib/libc-mes.hex2\ -f lib/libc-mes.o\
-f src/mes.hex2\ -f src/mes.o\
-f src/mes.blood-elf.hex2\ -f src/mes.o.blood-elf\
--exec_enable\ --exec_enable\
-o src/mes.seed-out -o src/mes.seed-out
cp src/mes.seed-out src/mes cp src/mes.seed-out src/mes
$M1\ $M1\
$M1FLAGS\ $M1FLAGS\
-f stage0/x86.M1\ -f stage0/x86.M1\
-f $MES_SEED/libc+tcc-mes.M1\ -f $MES_SEED/libc+tcc-mes.M1\
-o src/libc+tcc-mes.hex2 -o lib/libc+tcc-mes.o
fi fi
PREPROCESS=1 PREPROCESS=1
NOLINK=1 sh build-aux/cc-mes.sh lib/crt1 NOLINK=1 sh build-aux/cc-mes.sh lib/crt1
NOLINK=1 sh build-aux/cc-mes.sh lib/mini-libc-mes NOLINK=1 sh build-aux/cc-mes.sh lib/libc-mini-mes
NOLINK=1 sh build-aux/cc-mes.sh lib/libc-mes NOLINK=1 sh build-aux/cc-mes.sh lib/libc-mes
NOLINK=1 sh build-aux/cc-mes.sh lib/libc+tcc-mes NOLINK=1 sh build-aux/cc-mes.sh lib/libc+tcc-mes
cp lib/crt1.mes-o lib/crt1.o
cp lib/libc-mini-mes.mes-o lib/libc-mini-mes.o
cp lib/libc-mes.mes-o lib/libc-mes.o
cp lib/libc+tcc-mes.mes-o lib/libc+tcc-mes.o
[ -n "$SEED" ] && exit 0 [ -n "$SEED" ] && exit 0
GUILE=src/mes
MES_ARENA=${MES_ARENA-30000000} MES_ARENA=${MES_ARENA-30000000}
sh build-aux/mes-snarf.scm --mes src/gc.c 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/lib.c
@ -108,10 +118,10 @@ sh build-aux/mes-snarf.scm --mes src/posix.c
sh build-aux/mes-snarf.scm --mes src/reader.c sh build-aux/mes-snarf.scm --mes src/reader.c
sh build-aux/mes-snarf.scm --mes src/vector.c sh build-aux/mes-snarf.scm --mes src/vector.c
# sh build-aux/cc-mes.sh scaffold/main sh build-aux/cc-mes.sh scaffold/main
# sh build-aux/cc-mes.sh scaffold/hello sh build-aux/cc-mes.sh scaffold/hello
# sh build-aux/cc-mes.sh scaffold/argv sh build-aux/cc-mes.sh scaffold/argv
# sh build-aux/cc-mes.sh scaffold/malloc sh build-aux/cc-mes.sh scaffold/malloc
##sh build-aux/cc-mes.sh scaffold/micro-mes ##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/tiny-mes
# sh build-aux/cc-mes.sh scaffold/mini-mes # sh build-aux/cc-mes.sh scaffold/mini-mes

8
build-aux/build-mlibc.sh
View file

@ -18,7 +18,11 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex set -e
if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
export CC32 CPPFLAGS C32FLAGS export CC32 CPPFLAGS C32FLAGS
@ -59,7 +63,7 @@ C32FLAGS=${C32FLAGS-"
"} "}
NOLINK=1 sh build-aux/cc-mlibc.sh lib/crt1 NOLINK=1 sh build-aux/cc-mlibc.sh lib/crt1
NOLINK=1 sh build-aux/cc-mlibc.sh lib/mini-libc-gcc NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-mini-gcc
NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-gcc NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-gcc
NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc+tcc-gcc NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc+tcc-gcc

81
build-aux/cc-mes.sh
View file

@ -18,16 +18,16 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -x if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
export BLOOD_ELF GUILE HEX2 M1 MES MESCC export BLOOD_ELF GUILE HEX2 M1 MES MESCC
export M1FLAGS HEX2FLAGS PREPROCESS export M1FLAGS HEX2FLAGS PREPROCESS
export MES_SEED MES_ARENA
HEX2=${HEX2-hex2} HEX2=${HEX2-hex2}
M1=${M1-M1} M1=${M1-M1}
BLOOD_ELF=${BLOOD_ELF-blood-elf} BLOOD_ELF=${BLOOD_ELF-blood-elf}
MES_SEED=${MES_SEED-../mes-seed}
MESCC=${MESCC-$(command -v mescc)} MESCC=${MESCC-$(command -v mescc)}
[ -z "$MESCC" ] && MESCC=scripts/mescc [ -z "$MESCC" ] && MESCC=scripts/mescc
MES=${MES-$(command -v mes)} MES=${MES-$(command -v mes)}
@ -41,67 +41,32 @@ CPPFLAGS=${CPPFLAGS-"
-I lib -I lib
-I include -I include
"} "}
MESCCFLAGS=${MESCCFLAGS-"
"}
MESCCLAGS=${MESCCFLAGS-" if [ -n "$BUILD_DEBUG" ]; then
"} MESCCFLAGS="$MESCCFLAGS -v"
LIBC=${LIBC-lib/libc} fi
M1FLAGS=${M1FLAGS-"
--LittleEndian
--Architecture=1
"}
HEX2FLAGS=${HEX2FLAGS-"
--LittleEndian
--Architecture=1
--BaseAddress=0x1000000
"}
c=$1 c=$1
set -e set -e
if [ -n "$PREPROCESS" ]; then if [ -n "$PREPROCESS" ]; then
sh -x $MESCC\ sh $MESCC $MESCCFLAGS $CPPFLAGS -E "$c".c
-E\ sh $MESCC $MESCCFLAGS -S "$c".E
$CPPFLAGS\ sh $MESCC $MESCCFLAGS -c -o "$c".mes-o "$c".S
$MESCCFLAGS\ if [ -z "$NOLINK" ]; then
-o "$c".E\ sh $MESCC $MESCCFLAGS -o "$c".mes-out "$c".mes-o $MESCCLIBS
"$c".c fi
sh -x $MESCC\ elif [ -n "$COMPILE" ]; then
-c\ sh $MESCC $MESCCFLAGS $CPPFLAGS -S "$c".c
-o "$c".M1\ sh $MESCC $MESCCFLAGS -c -o "$c".mes-o "$c".S
"$c".E if [ -z "$NOLINK" ]; then
sh $MESCC $MESCCFLAGS -o "$c".mes-out "$c".mes-o $MESCCLIBS
fi
elif [ -z "$NOLINK" ]; then
sh $MESCC $MESCCFLAGS $CPPFLAGS -o "$c".mes-out "$c".c $MESCCLIBS
else else
sh -x $MESCC\ sh $MESCC $MESCCFLAGS $CPPFLAGS -c -o "$c".mes-out "$c".c
-c\
$CPPFLAGS\
$MESCCFLAGS\
-o "$c".M1\
"$c".c
fi
$M1\
$M1FLAGS\
-f stage0/x86.M1\
-f "$c".M1\
-o "$c".hex2
if [ -z "$NOLINK" ]; then
$BLOOD_ELF\
-f stage0/x86.M1\
-f "$c".M1\
-f $LIBC-mes.M1\
-o "$c".blood-elf-M1
$M1\
$M1FLAGS\
-f "$c".blood-elf-M1\
-o "$c".blood-elf-hex2
$HEX2\
$HEX2FLAGS\
-f stage0/elf32-header.hex2\
-f lib/crt1.hex2\
-f $LIBC-mes.hex2\
-f "$c".hex2\
-f "$c".blood-elf-hex2\
--exec_enable\
-o "$c".mes-out
fi fi

9
build-aux/cc-mlibc.sh
View file

@ -18,7 +18,11 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex set -e
if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
CPPFLAGS=${CPPFLAGS-" CPPFLAGS=${CPPFLAGS-"
-D VERSION=\"$VERSION\" -D VERSION=\"$VERSION\"
@ -56,5 +60,6 @@ if [ -z "$NOLINK" ]; then
-o "$c".mlibc-out\ -o "$c".mlibc-out\
lib/crt1.mlibc-o\ lib/crt1.mlibc-o\
"$c".mlibc-o\ "$c".mlibc-o\
$LIBC-gcc.mlibc-o $LIBC-gcc.mlibc-o\
$CC32LIBS
fi fi

6
build-aux/cc.sh
View file

@ -18,7 +18,11 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -ex set -e
if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
CPPFLAGS=${CPPFLAGS-" CPPFLAGS=${CPPFLAGS-"
-D VERSION=\"$VERSION\" -D VERSION=\"$VERSION\"

9
build-aux/check-boot.sh
View file

@ -18,12 +18,17 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -e
export GUILE MES export GUILE MES
GUILE=${GUILE-guile}
MES=${MES-./src/mes} MES=${MES-./src/mes}
GUILE=${GUILE-guile}
if ! command -v $GUILE > /dev/null; then
GUILE=true
fi
set -e
tests=" tests="
00-zero.scm 00-zero.scm

21
build-aux/check-mescc.sh
View file

@ -18,9 +18,15 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
export BLOOD_ELF GUILE HEX2 M1 MES MESCC export BLOOD_ELF GUILE HEX2 M1 MES MESCC
export M1FLAGS HEX2FLAGS PREPROCESS LIBC export M1FLAGS HEX2FLAGS PREPROCESS
export MES_ARENA MES_PREFIX MES_SEED export MES_ARENA MES_PREFIX MES_SEED
export BUILD_DEBUG
export CC32LIBS MESCCLIBS
MES=${MES-src/mes} MES=${MES-src/mes}
MESCC=${MESCC-scripts/mescc} MESCC=${MESCC-scripts/mescc}
@ -36,6 +42,9 @@ MESCC=${MESCC-$(command -v mescc)}
MES=${MES-$(command -v mes)} MES=${MES-$(command -v mes)}
[ -z "$MES" ] && MES=src/mes [ -z "$MES" ] && MES=src/mes
if ! command -v $GUILE > /dev/null; then
GUILE=true
fi
tests=" tests="
t t
@ -135,14 +144,18 @@ expect=$(echo $broken | wc -w)
pass=0 pass=0
fail=0 fail=0
total=0 total=0
MESCCLIBS=
LIBC=libc/libc LIBC=libc/libc
for t in $tests; do for t in $tests; do
if [ -z "${t/[012][0-9]-*/}" ]; then if [ -z "${t/[012][0-9]-*/}" ]; then
LIBC=lib/mini-libc; LIBC="lib/libc-mini"
MESCCLIBS="-l c-mini"
elif [ -z "${t/8[0-9]-*/}" ]; then elif [ -z "${t/8[0-9]-*/}" ]; then
LIBC=lib/libc+tcc; LIBC="lib/libc+tcc"
MESCCLIBS="-l c+tcc"
else else
LIBC=lib/libc; LIBC=libc/libc
MESCCLIBS=
fi fi
sh build-aux/test.sh "scaffold/tests/$t" &> scaffold/tests/"$t".log sh build-aux/test.sh "scaffold/tests/$t" &> scaffold/tests/"$t".log
r=$? r=$?

159
build-aux/compile-all.scm
View file

@ -1,159 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(use-modules (system base target)
(system base message)
(ice-9 match)
(ice-9 threads))
(define (mkdir-p dir)
"Create directory DIR and all its ancestors."
(define absolute?
(string-prefix? "/" dir))
(define not-slash
(char-set-complement (char-set #\/)))
(let loop ((components (string-tokenize dir not-slash))
(root (if absolute?
""
".")))
(match components
((head tail ...)
(let ((path (string-append root "/" head)))
(catch 'system-error
(lambda ()
(mkdir path)
(loop tail path))
(lambda args
(if (= EEXIST (system-error-errno args))
(loop tail path)
(apply throw args))))))
(() #t))))
(define warnings
'(unsupported-warning format unbound-variable arity-mismatch))
(define host (getenv "host"))
(define srcdir (getenv "srcdir"))
(define (relative-file file)
(if (string-prefix? (string-append srcdir "/") file)
(string-drop file (+ 1 (string-length srcdir)))
file))
(define (file-mtime<? f1 f2)
(< (stat:mtime (stat f1))
(stat:mtime (stat f2))))
(define (scm->go file)
(let* ((relative (relative-file file))
(without-extension (string-drop-right relative 4)))
(string-append without-extension ".go")))
(define (scm->mes file)
(let ((base (string-drop-right file 4)))
(string-append base ".mes")))
(define (file-needs-compilation? file)
(let ((go (scm->go file)))
(or (not (file-exists? go))
(file-mtime<? go file)
(let ((mes (scm->mes file))) ; FIXME: try to respect (include-from-path ".mes")
(and (file-exists? mes)
(file-mtime<? go mes))))))
(define (file->module file)
(let* ((relative (relative-file file))
(module-path (string-drop-right relative 4)))
(map string->symbol
(string-split module-path #\/))))
;;; To work around <http://bugs.gnu.org/15602> (FIXME), we want to load all
;;; files to be compiled first. We do this via resolve-interface so that the
;;; top-level of each file (module) is only executed once.
(define (load-module-file file)
(let ((module (file->module file)))
(format #t " LOAD ~a~%" module)
(resolve-interface module)))
(cond-expand
(guile-2.2 (use-modules (language tree-il optimize)
(language cps optimize)))
(else #f))
(define %default-optimizations
;; Default optimization options (equivalent to -O2 on Guile 2.2).
(cond-expand
(guile-2.2 (append (tree-il-default-optimization-options)
(cps-default-optimization-options)))
(else '())))
(define %lightweight-optimizations
;; Lightweight optimizations (like -O0, but with partial evaluation).
(let loop ((opts %default-optimizations)
(result '()))
(match opts
(() (reverse result))
((#:partial-eval? _ rest ...)
(loop rest `(#t #:partial-eval? ,@result)))
((kw _ rest ...)
(loop rest `(#f ,kw ,@result))))))
(define (optimization-options file)
(if (string-contains file "gnu/packages/")
%lightweight-optimizations ;build faster
'()))
(define (compile-file* file output-mutex)
(let ((go (scm->go file)))
(with-mutex output-mutex
(format #t " GUILEC ~a~%" go)
(force-output))
(mkdir-p (dirname go))
(with-fluids ((*current-warning-prefix* ""))
(with-target host
(lambda ()
(compile-file file
#:output-file go
#:opts `(#:warnings ,warnings
,@(optimization-options file))))))))
;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
;; opportunity to run upon SIGINT and to remove temporary output files.
(sigaction SIGINT
(lambda args
(exit 1)))
(match (command-line)
((_ . files)
(let ((files (filter file-needs-compilation? files)))
(for-each load-module-file files)
(let ((mutex (make-mutex)))
;; Make sure compilation related modules are loaded before starting to
;; compile files in parallel.
(compile #f)
(par-for-each (lambda (file)
(compile-file* file mutex))
files)))))
;;; Local Variables:
;;; eval: (put 'with-target 'scheme-indent-function 1)
;;; End:

6
build-aux/test.sh
View file

@ -18,9 +18,11 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -x if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
export LIBC export LIBC MESCCLIBS
GUILE=${GUILE-$MES} GUILE=${GUILE-$MES}
DIFF=${DIFF-$(command -v diff)} DIFF=${DIFF-$(command -v diff)}

8
build.sh
View file

@ -18,12 +18,16 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with Mes. If not, see <http://www.gnu.org/licenses/>. # along with Mes. If not, see <http://www.gnu.org/licenses/>.
set -x if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
# dash does not export foo=${foo-bar} for some values # dash does not export foo=${foo-bar} for some values
export CC CC32 GUILE MESCC MES_SEED export CC CC32 GUILE MESCC MES_SEED
export MES_ARENA MES_DEBUG export MES_ARENA MES_DEBUG
export PREFIX DATADIR MODULEDIR export PREFIX DATADIR MODULEDIR
export CPPFLAGS CFLAGS C32FLAGS MESCCFLAGS export CPPFLAGS CFLAGS C32FLAGS MESCCFLAGS
export BUILD_DEBUG
CC=${CC-$(command -v gcc)} CC=${CC-$(command -v gcc)}
CC32=${CC32-$(command -v i686-unknown-linux-gnu-gcc)} CC32=${CC32-$(command -v i686-unknown-linux-gnu-gcc)}
@ -31,7 +35,7 @@ MESCC=${MESCC-$(command -v mescc)}
MES_SEED=${MES_SEED-../mes-seed} MES_SEED=${MES_SEED-../mes-seed}
GUILE=${GUILE-$(command -v guile)} GUILE=${GUILE-$(command -v guile)}
MES_ARENA=${MES_ARENA-300000000} MES_ARENA=${MES_ARENA-300000000}
MES_DEBUG=${MES_DEBUG-2} MES_DEBUG=${MES_DEBUG-1}
PREFIX=${PREFIX-/usr/local} PREFIX=${PREFIX-/usr/local}
DATADIR=${DATADIR-$PREFIX/share/mes} DATADIR=${DATADIR-$PREFIX/share/mes}

9
check.sh
View file

@ -20,10 +20,17 @@
export CC32 export CC32
export GUILE MES MES_ARENA export GUILE MES MES_ARENA
export BUILD_DEBUG
CC32=${CC32-$(command -v i686-unknown-linux-gnu-gcc)} CC32=${CC32-$(command -v i686-unknown-linux-gnu-gcc)}
GUILE=${GUILE-guile} GUILE=${GUILE-guile}
MES=${MES-src/mes} MES=${MES-src/mes}
MES_ARENA=${MES_ARENA-100000000} MES_ARENA=${MES_ARENA-300000000}
PREFIX=
if ! command -v $GUILE > /dev/null; then
GUILE=true
fi
set -e set -e
bash build-aux/check-boot.sh bash build-aux/check-boot.sh

1
guile/mescc Symbolic link
View file

@ -0,0 +1 @@
../module/mescc

4
lib/libc-gcc.c
View file

@ -29,8 +29,8 @@
#include <fcntl.h> #include <fcntl.h>
#include <assert.h> #include <assert.h>
#include <mini-linux-gcc.c> #include <linux-mini-gcc.c>
#include <mini-libc.c> #include <libc-mini.c>
#include <linux-gcc.c> #include <linux-gcc.c>
#include <libc.c> #include <libc.c>

4
lib/libc-mes.c
View file

@ -25,7 +25,7 @@
void _env (); void _env ();
#include <mini-linux-mes.c> #include <linux-mini-mes.c>
#include <mini-libc.c> #include <libc-mini.c>
#include <linux-mes.c> #include <linux-mes.c>
#include <libc.c> #include <libc.c>

4
lib/mini-libc-gcc.c → lib/libc-mini-gcc.c
View file

@ -18,5 +18,5 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>. * along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/ */
#include <mini-linux-gcc.c> #include <linux-mini-gcc.c>
#include <mini-libc.c> #include <libc-mini.c>

4
lib/mini-libc-mes.c → lib/libc-mini-mes.c
View file

@ -18,5 +18,5 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>. * along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/ */
#include <mini-linux-mes.c> #include <linux-mini-mes.c>
#include <mini-libc.c> #include <libc-mini.c>

0
lib/mini-libc.c → lib/libc-mini.c
View file

0
lib/mini-linux-gcc.c → lib/linux-mini-gcc.c
View file

0
lib/mini-linux-mes.c → lib/linux-mini-mes.c
View file

61
module/language/c99/compiler.scm
View file

@ -1,61 +0,0 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (language c99 compiler)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (system base pmatch)
#:use-module (ice-9 optargs)
#:use-module (ice-9 pretty-print)
#:use-module (nyacc lang c99 parser)
;;#:use-module (nyacc lang c99 pprint)
#:use-module (mes guile)
#:use-module (mes as)
#:use-module (mes as-i386)
#:use-module (mes elf)
#:use-module (mes M1)
#:use-module (language c99 info)
#:export (c99-ast->info
c99-input->ast
c99-input->elf
c99-input->info
c99-input->object
info->object))
(cond-expand
(guile-2
(use-modules (nyacc lang c99 pprint)))
(guile
(debug-set! stack 0)
(use-modules (ice-9 optargs))
(use-modules (ice-9 syncase)))
;; guile-1.8 does not have (sxml match), short-circuit me
(define* (pretty-print-c99 tree
#:optional (port (current-output-port))
#:key ugly per-line-prefix (basic-offset 2))
(write tree port))
(mes))
(include-from-path "language/c99/compiler.mes")

44
module/mes/M1.scm
View file

@ -1,44 +0,0 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (mes M1)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (system base pmatch)
#:use-module (mes guile)
#:use-module (mes as)
#:use-module (mes elf)
#:use-module (language c99 info)
#:export (object->M1
objects->M1
object->elf
objects->elf))
(cond-expand
(guile-2)
(guile
(use-modules (ice-9 syncase)))
(mes))
(include-from-path "mes/M1.mes")

172
module/mes/as-i386.scm
View file

@ -1,172 +0,0 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; as-i386.scm defines i386 assembly
;;; Code:
(define-module (mes as-i386)
#:use-module (mes guile)
#:use-module (mes as)
#:export (
i386:accu%base
i386:accu*base
i386:accu*n->label
i386:accu*n->local
i386:accu+accu
i386:accu+base
i386:accu+value
i386:accu->base
i386:accu->base-mem
i386:byte-accu->base-mem
i386:word-accu->base-mem
i386:accu->base-mem+n
i386:byte-accu->base-mem+n
i386:word-accu->base-mem+n
i386:accu->label
i386:accu->local
i386:accu->local+n
i386:accu->local+n
i386:accu-and
i386:accu-and-base
i386:accu-and-base-mem
i386:accu-base
i386:accu-cmp-value
i386:accu-mem-add
i386:accu-mem->base-mem
i386:accu-negate
i386:accu-not
i386:accu-or-base
i386:accu-or-base-mem
i386:accu-shl
i386:accu-test
i386:accu-xor-base
i386:accu-zero?
i386:accu/base
i386:accu<->stack
i386:accu<<base
i386:accu>>base
i386:base+value
i386:base->accu
i386:base->accu-mem
i386:base->label
i386:base-mem->accu-mem
i386:base-mem+n->accu
i386:base-mem->accu
i386:base-sub
i386:byte-accu->base-mem
i386:word-accu->base-mem
i386:byte-base->accu-mem
i386:byte-base->accu-mem+n
i386:byte-base-mem->accu
i386:byte-base-sub
i386:byte-local->base
i386:byte-mem->accu
i386:word-mem->accu
i386:byte-mem->base
i386:byte-sub-base
i386:byte-test-base
i386:call-accu
i386:call-label
i386:formal
i386:function-locals
i386:function-preamble
i386:jump
i386:jump
i386:jump-a
i386:jump-ae
i386:jump-b
i386:jump-be
i386:jump-byte-z
i386:jump-g
i386:jump-ge
i386:jump-l
i386:jump-le
i386:jump-nz
i386:jump-z
i386:label->accu
i386:label->base
i386:label-mem->accu
i386:label-mem->base
i386:label-mem-add
i386:local->accu
i386:local->base
i386:local-add
i386:local-address->accu
i386:local-address->accu
i386:local-address->base
i386:local-ptr->accu
i386:local-ptr->base
i386:local-test
i386:mem+n->accu
i386:byte-mem+n->accu
i386:word-mem+n->accu
i386:mem->accu
i386:mem->base
i386:nop
i386:nz->accu
i386:pop-accu
i386:pop-base
i386:push-accu
i386:push-base
i386:push-byte-local-de-de-ref
i386:push-byte-local-de-ref
i386:push-word-local-de-ref
i386:push-label
i386:push-label-mem
i386:push-local
i386:push-local-address
i386:push-local-de-ref
i386:ret
i386:ret-local
i386:sub-base
i386:test-base
i386:value->accu
i386:value->accu-mem
i386:value->accu-mem+n
i386:value->base
i386:value->label
i386:value->local
i386:xor-accu
i386:xor-zf
i386:g?->accu
i386:ge?->accu
i386:l?->accu
i386:le?->accu
i386:a?->accu
i386:ae?->accu
i386:b?->accu
i386:be?->accu
i386:z->accu
i386:byte-accu
i386:signed-byte-accu
i386:word-accu
i386:signed-word-accu
))
(cond-expand
(guile-2)
(guile
(use-modules (ice-9 syncase)))
(mes))
(include-from-path "mes/as-i386.mes")

8
module/mes/boot-0.scm
View file

@ -152,7 +152,9 @@
(define-macro (load file) (define-macro (load file)
(list 'begin (list 'begin
(list 'if (list getenv "MES_DEBUG") (list 'if (list 'and (list getenv "MES_DEBUG")
(list not (list equal2? (list getenv "MES_DEBUG") "0"))
(list not (list equal2? (list getenv "MES_DEBUG") "1")))
(list 'begin (list 'begin
(list core:display-error ";;; read ") (list core:display-error ";;; read ")
(list core:display-error file) (list core:display-error file)
@ -190,7 +192,9 @@
"@VERSION@")) "@VERSION@"))
(define (effective-version) %version) (define (effective-version) %version)
(if (getenv "MES_DEBUG") (if (list 'and (list getenv "MES_DEBUG")
(list not (list equal2? (list getenv "MES_DEBUG") "0"))
(list not (list equal2? (list getenv "MES_DEBUG") "1")))
(begin (begin
(core:display-error ";;; %moduledir=") (core:display-error ";;; %moduledir=")
(core:display-error %moduledir) (core:display-error %moduledir)

13
module/mes/guile.mes
View file

@ -22,13 +22,16 @@
;;; Code: ;;; Code:
(mes-use-module (srfi srfi-13))
(define-macro (cond-expand-provide . rest) #t) (define-macro (cond-expand-provide . rest) #t)
(define-macro (include-from-path file) (define-macro (include-from-path file)
(let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:)))) (let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:))))
(if (getenv "MES_DEBUG") (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
;;(format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path) (core:display-error (string-append "include-from-path: " file "\n")))
(core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n"))) ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number)))
(core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
(if (null? path) (error "include-from-path: not found: " file) (if (null? path) (error "include-from-path: not found: " file)
(let ((file (string-append (car path) "/" file))) (let ((file (string-append (car path) "/" file)))
(if (access? file R_OK) `(load ,file) (if (access? file R_OK) `(load ,file)
@ -37,7 +40,6 @@
(mes-use-module (mes catch)) (mes-use-module (mes catch))
(mes-use-module (mes posix)) (mes-use-module (mes posix))
(mes-use-module (srfi srfi-16)) (mes-use-module (srfi srfi-16))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes display)) (mes-use-module (mes display))
(if #t ;;(not (defined? 'read-string)) (if #t ;;(not (defined? 'read-string))
@ -46,7 +48,7 @@
(if (eq? c #\*eof*) '() (if (eq? c #\*eof*) '()
(cons c (read-string (read-char))))) (cons c (read-string (read-char)))))
(let ((string (list->string (read-string (read-char))))) (let ((string (list->string (read-string (read-char)))))
(if (and=> (getenv "MES_DEBUG") (compose (cut > <> 3) string->number)) (if (and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 3)) string->number))
(core:display-error (string-append "drained: `" string "'\n"))) (core:display-error (string-append "drained: `" string "'\n")))
string))) string)))
@ -147,4 +149,3 @@
(with-output-to-string (with-output-to-string
(lambda () (simple-format lst rest)))))) (lambda () (simple-format lst rest))))))
(define format simple-format) (define format simple-format)

14
module/mes/elf.scm → module/mes/mescc.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*- ;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of Mes. ;;; This file is part of Mes.
;;; ;;;
@ -22,14 +22,4 @@
;;; Code: ;;; Code:
(define-module (mes elf) (include-from-path "mes/mescc.scm")
#:use-module (mes guile)
#:export (M1->elf))
(cond-expand
(guile-2)
(guile
(use-modules (ice-9 syncase)))
(mes))
(include-from-path "mes/elf.mes")

23
module/mes/as.scm → module/mes/misc.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*- ;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of Mes. ;;; This file is part of Mes.
;;; ;;;
@ -18,23 +18,4 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary: (include-from-path "mes/misc.scm")
;;; Code:
(define-module (mes as)
#:use-module (srfi srfi-1)
#:use-module (mes guile)
#:use-module (mes bytevectors)
#:export (dec->hex
int->bv8
int->bv16
int->bv32))
(cond-expand
(guile-2)
(guile
(use-modules (ice-9 syncase)))
(mes))
(include-from-path "mes/as.mes")

65
module/mes/misc.scm Normal file
View file

@ -0,0 +1,65 @@
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (mes misc)
#:use-module (srfi srfi-1)
#:export (%scheme
disjoin
guile?
mes?
pke
stderr
string-substitute))
(cond-expand
(mes
(define %scheme "mes"))
(guile
(define %scheme "guile")))
(define guile? (equal? %scheme "guile"))
(define mes? (equal? %scheme "mes"))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define (pke . stuff)
(newline (current-error-port))
(display ";;; " (current-error-port))
(write stuff (current-error-port))
(newline (current-error-port))
(car (last-pair stuff)))
(define (disjoin . predicates)
(lambda (. arguments)
(any (lambda (o) (apply o arguments)) predicates)))
(define (string-substitute string find replace)
(let ((index (string-contains string find)))
(if (not index) string
(string-append
(string-take string index)
replace
(string-substitute
(string-drop string (+ index (string-length find)))
find replace)))))

2
module/mes/posix.mes
View file

@ -22,6 +22,8 @@
;;; Code: ;;; Code:
(mes-use-module (srfi srfi-13))
(define R_OK 0) (define R_OK 0)
(define S_IRWXU #o700) (define S_IRWXU #o700)

28
module/mescc/M1.mes Normal file
View file

@ -0,0 +1,28 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes misc))
(mes-use-module (mes optargs))
(mes-use-module (mes pmatch))
(mes-use-module (mescc as))
(mes-use-module (mescc info))
(include-from-path "mescc/M1.scm")

69
module/mes/M1.mes → module/mescc/M1.scm
View file

@ -1,7 +1,5 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of Mes. ;;; This file is part of Mes.
;;; ;;;
@ -20,51 +18,31 @@
;;; Commentary: ;;; Commentary:
;;; M1.mes produces stage0' M1 object format ;;; M1.scm produces stage0' M1 assembly format
;;; Code: ;;; Code:
(cond-expand (define-module (mescc M1)
(guile) #:use-module (srfi srfi-1)
(mes #:use-module (srfi srfi-26)
(mes-use-module (srfi srfi-1)) #:use-module (system base pmatch)
(mes-use-module (srfi srfi-26)) #:use-module (mes misc)
(mes-use-module (mes as)) #:use-module (mes guile)
(mes-use-module (mes elf))
(mes-use-module (mes optargs))
(mes-use-module (mes pmatch))
(mes-use-module (language c99 info))))
(define (logf port string . rest) #:use-module (mescc as)
(apply format (cons* port string rest)) #:use-module (mescc info)
(force-output port) #:export (info->M1
#t) infos->M1
M1:merge-infos))
(define (stderr string . rest) (define (infos->M1 file-name infos)
(apply logf (cons* (current-error-port) string rest))) (let ((info (fold M1:merge-infos (make <info>) infos)))
(info->M1 file-name info)))
(define (pke . stuff) (define (M1:merge-infos o info)
(newline (current-error-port)) (clone info
(display ";;; " (current-error-port)) #:functions (alist-add (.functions info) (.functions o))
(write stuff (current-error-port)) #:globals (alist-add (.globals info) (.globals o))))
(newline (current-error-port))
(car (last-pair stuff)))
(define (objects->M1 file-name objects)
((compose (cut object->M1 file-name <>) merge-objects) objects))
(define (object->elf file-name o)
((compose M1->elf (cut object->M1 file-name <>)) o))
(define (objects->elf file-name objects)
((compose M1->elf (cut object->M1 file-name <>) merge-objects) objects))
(define (merge-objects objects)
(let loop ((objects (cdr objects)) (object (car objects)))
(if (null? objects) object
(loop (cdr objects)
`((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
(globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
(define (alist-add a b) (define (alist-add a b)
(let* ((b-keys (map car b)) (let* ((b-keys (map car b))
@ -99,11 +77,10 @@
(display sep)) (display sep))
(loop (cdr o))))) (loop (cdr o)))))
(define (object->M1 file-name o) (define (info->M1 file-name o)
(stderr "dumping M1: object\n") (let* ((functions (.functions o))
(let* ((functions (assoc-ref o 'functions))
(function-names (map car functions)) (function-names (map car functions))
(globals (assoc-ref o 'globals)) (globals (.globals o))
(global-names (map car globals)) (global-names (map car globals))
(strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names))) (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
(define (string->label o) (define (string->label o)

17
module/mes/elf.mes → module/mescc/as.mes
View file

@ -1,4 +1,4 @@
<;;; -*-scheme-*- ;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
@ -18,15 +18,6 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary: (mes-use-module (srfi srfi-1))
(mes-use-module (mescc bytevectors))
;;; elf.mes - produce a i386 elf executable. (include-from-path "mescc/as.scm")
;;; Code:
(cond-expand
(guile)
(mes))
(define (M1->elf objects)
(error "->ELF support dropped, use M1"))

25
module/mes/as.mes → module/mescc/as.scm
View file

@ -1,7 +1,5 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of Mes. ;;; This file is part of Mes.
;;; ;;;
@ -18,19 +16,14 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary: (define-module (mescc as)
#:use-module (srfi srfi-1)
;;; compiler.mes produces an i386 binary from the C produced by #:use-module (mes guile)
;;; Nyacc c99. #:use-module (mescc bytevectors)
#:export (dec->hex
;;; Code: int->bv8
int->bv16
(cond-expand int->bv32))
(guile)
(guile-2)
(mes
(mes-use-module (srfi srfi-1))
(mes-use-module (mes bytevectors))))
(define (int->bv32 value) (define (int->bv32 value)
(let ((bv (make-bytevector 4))) (let ((bv (make-bytevector 4)))

21
module/mescc/bytevectors.mes Normal file
View file

@ -0,0 +1,21 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(include-from-path "mescc/bytevectors.scm")

11
module/mes/bytevectors.mes → module/mescc/bytevectors.scm
View file

@ -1,5 +1,3 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
@ -20,10 +18,15 @@
;;; Commentary: ;;; Commentary:
;;; bytevectors.mes
;;; Code: ;;; Code:
(define-module (mescc bytevectors)
#:use-module (mes guile)
#:export (bytevector-u32-native-set!
bytevector-u16-native-set!
bytevector-u8-set!
make-bytevector))
;; rnrs compatibility ;; rnrs compatibility
(define (bytevector-u32-native-set! bv index value) (define (bytevector-u32-native-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value)) (when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value))

33
module/mescc/compile.mes Normal file
View file

@ -0,0 +1,33 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-13))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes pmatch))
(mes-use-module (mes optargs))
(mes-use-module (mes misc))
(mes-use-module (nyacc lang c99 pprint))
(mes-use-module (mescc as))
(mes-use-module (mescc i386 as))
(mes-use-module (mescc info))
(mes-use-module (mescc M1))
(include-from-path "mescc/compile.scm")

172
module/language/c99/compiler.mes → module/mescc/compile.scm
View file

@ -1,5 +1,3 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
@ -20,119 +18,48 @@
;;; Commentary: ;;; Commentary:
;;; compiler.mes produces an i386 binary from the C produced by
;;; Nyacc c99.
;;; Code: ;;; Code:
(cond-expand (define-module (mescc compile)
(guile-2) #:use-module (srfi srfi-1)
(guile) #:use-module (srfi srfi-9 gnu)
(mes #:use-module (srfi srfi-26)
(mes-use-module (srfi srfi-1)) #:use-module (system base pmatch)
(mes-use-module (srfi srfi-26)) #:use-module (ice-9 optargs)
(mes-use-module (mes pmatch)) #:use-module (ice-9 pretty-print)
(mes-use-module (nyacc lang c99 parser)) #:use-module (nyacc lang c99 pprint)
(mes-use-module (nyacc lang c99 pprint))
(mes-use-module (mes as))
(mes-use-module (mes as-i386))
(mes-use-module (mes M1))
(mes-use-module (mes optargs))
(mes-use-module (language c99 info))))
(define (logf port string . rest) #:use-module (mes guile)
(apply format (cons* port string rest)) #:use-module (mes misc)
(force-output port)
#t)
(define (stderr string . rest) #:use-module (mescc preprocess)
(apply logf (cons* (current-error-port) string rest))) #:use-module (mescc info)
#:use-module (mescc as)
(define (pke . stuff) #:use-module (mescc i386 as)
(newline (current-error-port)) #:use-module (mescc M1)
(display ";;; " (current-error-port)) #:export (c99-ast->info
(write stuff (current-error-port)) c99-input->info
(newline (current-error-port)) c99-input->object))
(car (last-pair stuff)))
(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "PREFIX") "") "@PREFIX@"))
(define mes? (pair? (current-module))) (define mes? (pair? (current-module)))
(define* (c99-input->info #:key (prefix "") (defines '()) (includes '()))
(let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes)))
(c99-ast->info ast)))
(define* (c99-ast->info o)
(stderr "compiling: input\n")
(let ((info (ast->info o (make <info> #:types i386:type-alist))))
(clean-info info)))
(define (clean-info o)
(make <info>
#:functions (filter (compose pair? function:text cdr) (.functions o))
#:globals (.globals o)))
(define %int-size 4) (define %int-size 4)
(define %pointer-size %int-size) (define %pointer-size %int-size)
(define* (c99-input->full-ast #:key (defines '()) (includes '()))
(let ((sys-include (if (equal? %prefix "") "include" (string-append %prefix "/share/include"))))
(parse-c99
#:inc-dirs (append includes (cons* sys-include "include" "lib" (or (and=> (getenv "C_INCLUDE_PATH") (cut string-split <> #\:)) '())))
#:cpp-defs `(
"NULL=0"
"__linux__=1"
"__i386__=1"
"POSIX=0"
"_POSIX_SOURCE=0"
"__MESC__=1"
,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
,@defines)
#:mode 'code)))
(define (ast-strip-comment o)
(pmatch o
((comment . ,comment) #f)
(((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
(((comment . ,comment) . ,cdr) cdr)
((,car . (comment . ,comment)) car)
((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
(cons (ast-strip-comment h) (ast-strip-comment t))))
(_ o)))
(define (ast-strip-const o)
(pmatch o
((type-qual ,qual) (if (equal? qual "const") #f o))
((pointer (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(pointer ,@rest) o))
((decl-spec-list (type-qual ,qual))
(if (equal? qual "const") #f
`(decl-spec-list (type-qual ,qual))))
((decl-spec-list (type-qual ,qual) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
(cons (ast-strip-const h) (ast-strip-const t))))
(_ o)))
(define (clone o . rest)
(cond ((info? o)
(let ((types (.types o))
(constants (.constants o))
(functions (.functions o))
(globals (.globals o))
(locals (.locals o))
(statics (.statics o))
(function (.function o))
(text (.text o))
(post (.post o))
(break (.break o))
(continue (.continue o)))
(let-keywords rest
#f
((types types)
(constants constants)
(functions functions)
(globals globals)
(locals locals)
(statics statics)
(function function)
(text text)
(post post)
(break break)
(continue continue))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue))))))
(define (ident->constant name value) (define (ident->constant name value)
(cons name value)) (cons name value))
@ -755,7 +682,11 @@
(define (ast->comment o) (define (ast->comment o)
(if mes? '() (if mes? '()
(let ((source (with-output-to-string (lambda () (pretty-print-c99 o))))) (let* ((source (with-output-to-string (lambda () (pretty-print-c99 o))))
;; Nyacc 0.80.42 fixups
(source (string-substitute source "'\\'" "'\\\\'"))
(source (string-substitute source "'\"'" "'\\\"'"))
(source (string-substitute source "'''" "'\\''")))
(make-comment (string-join (string-split source #\newline) " "))))) (make-comment (string-join (string-split source #\newline) " ")))))
(define (accu*n info n) (define (accu*n info n)
@ -2496,32 +2427,3 @@
#:globals (append (.statics info) (.globals info)) #:globals (append (.statics info) (.globals info))
#:statics '() #:statics '()
#:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info)))))))))) #:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info))))))))))
;; exports
(define* (c99-ast->info o)
(ast->info o (make <info> #:types i386:type-alist)))
(define* (c99-input->ast #:key (defines '()) (includes '()))
(stderr "parsing: input\n")
((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:defines defines #:includes includes)))
(define* (c99-input->info #:key (defines '()) (includes '()))
(lambda ()
(let* ((info (make <info> #:types i386:type-alist))
(ast (c99-input->ast #:defines defines #:includes includes))
(foo (stderr "compiling: input\n"))
(info (ast->info ast info))
(info (clone info #:text '() #:locals '())))
info)))
(define* (info->object o)
(stderr "compiling: object\n")
`((functions . ,(filter (compose pair? function:text cdr) (.functions o)))
(globals . ,(.globals o))))
(define* (c99-input->elf #:key (defines '()) (includes '()))
((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
(define* (c99-input->object #:key (defines '()) (includes '()))
((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))

22
module/mescc/i386/as.mes Normal file
View file

@ -0,0 +1,22 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(mes-use-module (mescc as))
(include-from-path "mescc/i386/as.scm")

149
module/mes/as-i386.mes → module/mescc/i386/as.scm
View file

@ -1,7 +1,5 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of Mes. ;;; This file is part of Mes.
;;; ;;;
@ -20,15 +18,148 @@
;;; Commentary: ;;; Commentary:
;;; as-i386.mes defines i386 assembly ;;; define i386 assembly
;;; Code: ;;; Code:
(cond-expand (define-module (mescc i386 as)
(guile-2) #:use-module (mes guile)
(guile) #:use-module (mescc as)
(mes #:export (
(mes-use-module (mes as)))) i386:accu%base
i386:accu*base
i386:accu*n->label
i386:accu*n->local
i386:accu+accu
i386:accu+base
i386:accu+value
i386:accu->base
i386:accu->base-mem
i386:byte-accu->base-mem
i386:word-accu->base-mem
i386:accu->base-mem+n
i386:byte-accu->base-mem+n
i386:word-accu->base-mem+n
i386:accu->label
i386:accu->local
i386:accu->local+n
i386:accu->local+n
i386:accu-and
i386:accu-and-base
i386:accu-and-base-mem
i386:accu-base
i386:accu-cmp-value
i386:accu-mem-add
i386:accu-mem->base-mem
i386:accu-negate
i386:accu-not
i386:accu-or-base
i386:accu-or-base-mem
i386:accu-shl
i386:accu-test
i386:accu-xor-base
i386:accu-zero?
i386:accu/base
i386:accu<->stack
i386:accu<<base
i386:accu>>base
i386:base+value
i386:base->accu
i386:base->accu-mem
i386:base->label
i386:base-mem->accu-mem
i386:base-mem+n->accu
i386:base-mem->accu
i386:base-sub
i386:byte-accu->base-mem
i386:word-accu->base-mem
i386:byte-base->accu-mem
i386:byte-base->accu-mem+n
i386:byte-base-mem->accu
i386:byte-base-sub
i386:byte-local->base
i386:byte-mem->accu
i386:word-mem->accu
i386:byte-mem->base
i386:byte-sub-base
i386:byte-test-base
i386:call-accu
i386:call-label
i386:formal
i386:function-locals
i386:function-preamble
i386:jump
i386:jump
i386:jump-a
i386:jump-ae
i386:jump-b
i386:jump-be
i386:jump-byte-z
i386:jump-g
i386:jump-ge
i386:jump-l
i386:jump-le
i386:jump-nz
i386:jump-z
i386:label->accu
i386:label->base
i386:label-mem->accu
i386:label-mem->base
i386:label-mem-add
i386:local->accu
i386:local->base
i386:local-add
i386:local-address->accu
i386:local-address->accu
i386:local-address->base
i386:local-ptr->accu
i386:local-ptr->base
i386:local-test
i386:mem+n->accu
i386:byte-mem+n->accu
i386:word-mem+n->accu
i386:mem->accu
i386:mem->base
i386:nop
i386:nz->accu
i386:pop-accu
i386:pop-base
i386:push-accu
i386:push-base
i386:push-byte-local-de-de-ref
i386:push-byte-local-de-ref
i386:push-word-local-de-ref
i386:push-label
i386:push-label-mem
i386:push-local
i386:push-local-address
i386:push-local-de-ref
i386:ret
i386:ret-local
i386:sub-base
i386:test-base
i386:value->accu
i386:value->accu-mem
i386:value->accu-mem+n
i386:value->base
i386:value->label
i386:value->local
i386:xor-accu
i386:xor-zf
i386:g?->accu
i386:ge?->accu
i386:l?->accu
i386:le?->accu
i386:a?->accu
i386:ae?->accu
i386:b?->accu
i386:be?->accu
i386:z->accu
i386:byte-accu
i386:signed-byte-accu
i386:word-accu
i386:signed-word-accu
))
(define (i386:nop) (define (i386:nop)
'(("nop"))) '(("nop")))

6
module/language/c99/info.mes → module/mescc/info.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*- ;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of Mes. ;;; This file is part of Mes.
;;; ;;;
@ -24,5 +24,5 @@
(mes-use-module (srfi srfi-9)) (mes-use-module (srfi srfi-9))
(mes-use-module (srfi srfi-9 gnu)) (mes-use-module (srfi srfi-9 gnu))
(include-from-path "language/c99/info.scm") (mes-use-module (mes optargs))
(include-from-path "mescc/info.scm")

48
module/language/c99/info.scm → module/mescc/info.scm
View file

@ -1,5 +1,3 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
@ -18,17 +16,20 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; info.scm defines [Guile] record data types for compiler.mes ;;; Commentary:
;;; info.scm defines [Guile] record data types for MesCC
;;; Code: ;;; Code:
(define-module (language c99 info) (define-module (mescc info)
#:use-module (ice-9 optargs) #:use-module (ice-9 optargs)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (<info> #:export (<info>
make make
clone
make-<info> make-<info>
info? info?
@ -113,14 +114,6 @@
rank+= rank+=
structured-type?)) structured-type?))
(cond-expand
(guile-2)
(guile
(use-modules (ice-9 syncase))
(use-modules (ice-9 optargs)))
(mes
(mes-use-module (mes optargs))))
(define-immutable-record-type <info> (define-immutable-record-type <info>
(make-<info> types constants functions globals locals statics function text post break continue) (make-<info> types constants functions globals locals statics function text post break continue)
info? info?
@ -137,7 +130,36 @@
(continue .continue)) (continue .continue))
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '())) (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '()))
(make-<info> types constants functions globals locals statics function text post break continue)) (cond ((eq? o <info>)
(make-<info> types constants functions globals locals statics function text post break continue))))
(define (clone o . rest)
(cond ((info? o)
(let ((types (.types o))
(constants (.constants o))
(functions (.functions o))
(globals (.globals o))
(locals (.locals o))
(statics (.statics o))
(function (.function o))
(text (.text o))
(post (.post o))
(break (.break o))
(continue (.continue o)))
(let-keywords rest
#f
((types types)
(constants constants)
(functions functions)
(globals globals)
(locals locals)
(statics statics)
(function function)
(text text)
(post post)
(break break)
(continue continue))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue))))))
;; ("int" . ,(make-type 'builtin 4 #f 0 #f)) ;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
;; (make-type 'enum 4 0 fields) ;; (make-type 'enum 4 0 fields)

29
module/mes/bytevectors.scm → module/mescc/mescc.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*- ;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of Mes. ;;; This file is part of Mes.
;;; ;;;
@ -18,21 +18,14 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary: (mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-13))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes misc))
(mes-use-module (mes getopt-long))
;;; Code: (mes-use-module (mes guile))
(mes-use-module (mescc preprocess))
(define-module (mes bytevectors) (mes-use-module (mescc compile))
#:use-module (mes guile) (mes-use-module (mescc M1))
#:export (bytevector-u32-native-set! (include-from-path "mescc/mescc.scm")
bytevector-u16-native-set!
bytevector-u8-set!
make-bytevector))
(cond-expand
(guile-2)
(guile
(use-modules (ice-9 syncase)))
(mes))
(include-from-path "mes/bytevectors.mes")

232
module/mescc/mescc.scm Normal file
View file

@ -0,0 +1,232 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (mescc mescc)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 getopt-long)
#:use-module (mes guile)
#:use-module (mes misc)
#:use-module (mescc preprocess)
#:use-module (mescc compile)
#:use-module (mescc M1)
#:export (mescc:preprocess
mescc:compile
mescc:assemble
mescc:link))
(define (mescc:preprocess options)
(let* ((defines (reverse (filter-map (multi-opt 'define) options)))
(includes (reverse (filter-map (multi-opt 'include) options)))
(pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
(pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
(files (option-ref options '() '("a.c")))
(input-file-name (car files))
(ast-file-name (cond ((and (option-ref options 'preprocess #f)
(option-ref options 'output #f)))
(else (replace-suffix input-file-name ".E"))))
(prefix (option-ref options 'prefix "")))
(with-output-to-file ast-file-name
(lambda _ (for-each (cut c->ast prefix defines includes write <>) files)))))
(define (c->ast prefix defines includes write file-name)
(with-input-from-file file-name
(cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes))))
(define (mescc:compile options)
(let* ((files (option-ref options '() '("a.c")))
(input-file-name (car files))
(M1-file-name (cond ((and (option-ref options 'compile #f)
(option-ref options 'output #f)))
(else (replace-suffix input-file-name ".S"))))
(infos (map (cut file->info options <>) files))
(verbose? (option-ref options 'verbose #f)))
(when verbose?
(stderr "dumping: ~a\n" M1-file-name))
(with-output-to-file M1-file-name
(cut infos->M1 M1-file-name infos))
M1-file-name))
(define (file->info options file-name)
(cond ((.c? file-name) (c->info options file-name))
((.E? file-name) (E->info options file-name))))
(define (c->info options file-name)
(let ((defines (reverse (filter-map (multi-opt 'define) options)))
(includes (reverse (filter-map (multi-opt 'include) options)))
(prefix (option-ref options 'prefix "")))
(with-input-from-file file-name
(cut c99-input->info #:prefix prefix #:defines defines #:includes includes))))
(define (E->info options file-name)
(let ((ast (with-input-from-file file-name read)))
(c99-ast->info ast)))
(define (mescc:assemble options)
(let* ((files (option-ref options '() '("a.c")))
(input-file-name (car files))
(hex2-file-name (cond ((and (option-ref options 'assemble #f)
(option-ref options 'output #f)))
(else (replace-suffix input-file-name ".o"))))
(S-files (filter .S? files))
(hex2-files M1->hex2 ) ;; FIXME
(source-files (filter (disjoin .c? .E?) files))
(infos (map (cut file->info options <>) source-files)))
(if (and (pair? S-files) (pair? infos))
(error "mixing source and object not supported:" source-files S-files))
(when (pair? S-files)
(M1->hex2 options S-files))
(when (pair? infos)
(infos->hex2 options hex2-file-name infos))
hex2-file-name))
(define (mescc:link options)
(define (library->hex2 o)
(prefix-file options (string-append "lib/lib" o "-mes.o")))
(let* ((files (option-ref options '() '("a.c")))
(source-files (filter (disjoin .c? .E?) files))
(S-files (filter .S? files))
(o-files (filter .o? files))
(input-file-name (car files))
(hex2-file-name (if (or (string-suffix? ".hex2" input-file-name)
(string-suffix? ".o" input-file-name)) input-file-name
(replace-suffix input-file-name ".o")))
(infos (map (cut file->info options <>) source-files))
(S-files (filter .S? files))
(hex2-files (filter .o? files))
(hex2-files (if (null? S-files) hex2-files
(append hex2-files (list (M1->hex2 options S-files)))))
(hex2-files (if (null? infos) hex2-files
(append hex2-files
(list (infos->hex2 options hex2-file-name infos)))))
(libraries (filter-map (multi-opt 'library) options))
(libraries (if (pair? libraries) libraries '("c")))
(hex2-libraries (map library->hex2 libraries))
(hex2-files (append hex2-files hex2-libraries))
(S-files (append S-files (map (cut replace-suffix <> ".S") hex2-libraries)))
(debug-info? (option-ref options 'debug-info #f))
(S-files (cons (replace-suffix input-file-name ".S") S-files))
(elf-footer (and debug-info?
(or (M1->blood-elf options S-files)
(exit 1)))))
(or (hex2->elf options hex2-files #:elf-footer elf-footer)
(exit 1))))
(define (infos->hex2 options hex2-file-name infos)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(M1-file-name (replace-suffix hex2-file-name ".S"))
(options (acons 'compile #t options)) ; ugh
(options (acons 'output hex2-file-name options))
(verbose? (option-ref options 'verbose #f)))
(when verbose?
(stderr "dumping: ~a\n" M1-file-name))
(with-output-to-file M1-file-name
(cut infos->M1 M1-file-name infos))
(or (M1->hex2 options (list M1-file-name))
(exit 1))))
(define (M1->hex2 options M1-files)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(M1-file-name (car M1-files))
(hex2-file-name (cond ((and (option-ref options 'assemble #f)
(option-ref options 'output #f)))
((option-ref options 'assemble #f)
(replace-suffix input-file-name ".o"))
(else (replace-suffix M1-file-name ".o"))))
(verbose? (option-ref options 'verbose #f))
(M1 (or (getenv "M1") "M1"))
(command `(,M1
"--LittleEndian"
"--Architecture=1"
"-f" ,(prefix-file options "stage0/x86.M1")
,@(append-map (cut list "-f" <>) M1-files)
"-o" ,hex2-file-name)))
(when verbose?
(stderr "~a\n" (string-join command)))
(and (zero? (apply system* command))
hex2-file-name)))
(define* (hex2->elf options hex2-files #:key elf-footer)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(elf-file-name (cond ((option-ref options 'output #f))
(else (replace-suffix input-file-name ""))))
(verbose? (option-ref options 'verbose #f))
(elf-footer (or elf-footer (prefix-file options "stage0/elf32-footer-single-main.hex2")))
(hex2 (or (getenv "HEX2") "hex2"))
(command `(,hex2
"--LittleEndian"
"--Architecture=1"
"--BaseAddress=0x1000000"
"-f" ,(prefix-file options "stage0/elf32-header.hex2")
"-f" ,(prefix-file options "lib/crt1.o")
,@(append-map (cut list "-f" <>) hex2-files)
"-f" ,elf-footer
"--exec_enable"
"-o" ,elf-file-name)))
(when verbose?
(stderr "command=~s\n" command)
(format (current-error-port) "~a\n" (string-join command)))
(and (zero? (apply system* command))
elf-file-name)))
(define (M1->blood-elf options M1-files)
(let* ((M1-file-name (car M1-files))
(M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
(hex2-file-name (replace-suffix M1-file-name ".o"))
(blood-elf-footer (string-append hex2-file-name ".blood-elf"))
(verbose? (option-ref options 'verbose #f))
(blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
(command `(,blood-elf
"-f" ,(prefix-file options "stage0/x86.M1")
,@(append-map (cut list "-f" <>) M1-files)
"-o" ,M1-blood-elf-footer)))
(when verbose?
(format (current-error-port) "~a\n" (string-join command)))
(and (zero? (apply system* command))
(let* ((options (acons 'compile #t options)) ; ugh
(options (acons 'output blood-elf-footer options)))
(M1->hex2 options (list M1-blood-elf-footer))))))
(define (replace-suffix file-name suffix)
(let* ((parts (string-split file-name #\.))
(base (if (pair? (cdr parts)) (drop-right parts 1))))
(string-append (string-join base ".") suffix)))
(define (prefix-file options file-name)
(let ((prefix (option-ref options 'prefix "")))
(define (prefix-file o)
(if (string-null? prefix) o (string-append prefix "/" o)))
(prefix-file file-name)))
(define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
(define (.c? o) (or (string-suffix? ".c" o)
(string-suffix? ".M2" o)))
(define (.E? o) (string-suffix? ".E" o))
(define (.S? o) (or (string-suffix? ".S" o)
(string-suffix? ".mes-S" o)
(string-suffix? "S" o)
(string-suffix? ".M1" o)))
(define (.o? o) (or (string-suffix? ".o" o)
(string-suffix? ".mes-o" o)
(string-suffix? "o" o)
(string-suffix? ".hex2" o)))

27
module/mescc/preprocess.mes Normal file
View file

@ -0,0 +1,27 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(mes-use-module (mes optargs))
(mes-use-module (mes pmatch))
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-13))
(mes-use-module (srfi srfi-26))
(mes-use-module (nyacc lang c99 parser))
(include-from-path "mescc/preprocess.scm")

87
module/mescc/preprocess.scm Normal file
View file

@ -0,0 +1,87 @@
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (mescc preprocess)
#:use-module (ice-9 optargs)
#:use-module (system base pmatch)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (nyacc lang c99 parser)
#:use-module (mes guile)
#:export (c99-input->ast))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define mes? (pair? (current-module)))
(define* (c99-input->full-ast #:key (prefix "") (defines '()) (includes '()))
(let ((sys-include (if (equal? prefix "") "include" (string-append prefix "/share/include"))))
(parse-c99
#:inc-dirs (append includes (cons* sys-include "include" "lib" (or (and=> (getenv "C_INCLUDE_PATH") (cut string-split <> #\:)) '())))
#:cpp-defs `(
"NULL=0"
"__linux__=1"
"__i386__=1"
"POSIX=0"
"_POSIX_SOURCE=0"
"__MESC__=1"
,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
,@defines)
#:mode 'code)))
(define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()))
(stderr "parsing: input\n")
((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:prefix prefix #:defines defines #:includes includes)))
(define (ast-strip-comment o)
(pmatch o
((comment . ,comment) #f)
(((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
(((comment . ,comment) . ,cdr) cdr)
((,car . (comment . ,comment)) car)
((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
(cons (ast-strip-comment h) (ast-strip-comment t))))
(_ o)))
(define (ast-strip-const o)
(pmatch o
((type-qual ,qual) (if (equal? qual "const") #f o))
((pointer (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(pointer ,@rest) o))
((decl-spec-list (type-qual ,qual))
(if (equal? qual "const") #f
`(decl-spec-list (type-qual ,qual))))
((decl-spec-list (type-qual ,qual) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
(cons (ast-strip-const h) (ast-strip-const t))))
(_ o)))

6
module/srfi/srfi-1.mes
View file

@ -131,10 +131,4 @@
(loop (cdr lst)) (loop (cdr lst))
(cons (car lst) (loop (cdr lst)))))))) (cons (car lst) (loop (cdr lst))))))))
(define (drop lst n)
(list-tail lst n))
(define (drop-right lst n)
(list-head lst (- (length lst) n)))
(include-from-path "srfi/srfi-1.scm") (include-from-path "srfi/srfi-1.scm")

7
module/srfi/srfi-13.mes
View file

@ -24,7 +24,6 @@
;;; Code: ;;; Code:
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-14)) (mes-use-module (srfi srfi-14))
(define (string-join lst . delimiter+grammar) (define (string-join lst . delimiter+grammar)
@ -76,10 +75,12 @@
((> n 0) (list->string (list-tail (string->list s) n))) ((> n 0) (list->string (list-tail (string->list s) n)))
(else s (error "string-drop: not supported: (n s)=" (cons n s))))) (else s (error "string-drop: not supported: (n s)=" (cons n s)))))
(define (drop-right lst n)
(list-head lst (- (length lst) n)))
(define (string-drop-right s n) (define (string-drop-right s n)
(cond ((zero? n) s) (cond ((zero? n) s)
((> n 0) (let ((length (string-length s))) ((> n 0) ((compose list->string (lambda (o) (drop-right o n)) string->list) s))
(list->string (list-head (string->list s) (- length n)))))
(else (error "string-drop-right: not supported: n=" n)))) (else (error "string-drop-right: not supported: n=" n))))
(define (string-delete pred s) (define (string-delete pred s)

162
scripts/mescc
View file

@ -1,5 +1,14 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
PREFIX=${PREFIX-@PREFIX@}
if [ "$PREFIX" = @PREFIX""@ -o ! -d "$PREFIX" ]
then
MES_PREFIX=${MES_PREFIX-$(cd $(dirname $0)/.. && pwd)}
export MES_PREFIX
fi
mes_p=$(command -v mes) mes_p=$(command -v mes)
if [ '(' -z "$mes_p" -a -z "$MES" ')' -o "$MES" = "guile" -o "$MES" = "mes.guile" ]; then if [ '(' -z "$mes_p" -a -z "$MES" ')' -o "$MES" = "guile" -o "$MES" = "mes.guile" ]; then
GODIR=${GODIR-@GODIR@} GODIR=${GODIR-@GODIR@}
@ -11,18 +20,9 @@ if [ '(' -z "$mes_p" -a -z "$MES" ')' -o "$MES" = "guile" -o "$MES" = "mes.guile
exec ${GUILE-guile} -L $GUILEDIR -e '(mescc)' -s "$0" "$@" exec ${GUILE-guile} -L $GUILEDIR -e '(mescc)' -s "$0" "$@"
else else
MES=${MES-$(dirname $0)/mes} MES=${MES-$(dirname $0)/mes}
PREFIX=${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"} MES_MODULEDIR=${MES_MODULEDIR-$MES_PREFIX/"module"}
export MES_MODULEDIR export MES_MODULEDIR
exec ${MES-mes} -e '(mescc)' -s $0 "$@" exec ${MES-mes} -e '(mescc)' -s $0 "$@"
exit $?
fi fi
!# !#
@ -44,63 +44,43 @@ fi
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
#!
Run with Guile-1.8:
GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' scripts/mescc
!#
(define-module (mescc) (define-module (mescc)
#:use-module (language c99 info)
#:use-module (language c99 compiler)
#:use-module (mes elf)
#:use-module (mes M1)
#:use-module (ice-9 getopt-long) #:use-module (ice-9 getopt-long)
#:use-module (ice-9 pretty-print) #:use-module (mes misc)
#:use-module (srfi srfi-1) #:use-module (mescc mescc)
#:use-module (srfi srfi-26)
#:export (main)) #:export (main))
(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "MES_PREFIX") "") "@PREFIX@")) (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "MES_PREFIX") "") "@PREFIX@"))
(define %version (if (string-prefix? "@VERSION" "@VERSION@") "git"
"@VERSION@"))
(cond-expand (cond-expand
(mes (mes
(define %scheme "mes") (define (set-port-encoding! port encoding) #t)
(define (set-port-encoding! port encoding) #t)) (mes-use-module (mes guile))
(guile-2 (mes-use-module (mes misc))
(define %scheme "guile") (mes-use-module (mes getopt-long))
(define-macro (mes-use-module . rest) #t) (mes-use-module (mes display))
(module-define! (resolve-module '(language c99 compiler)) '%prefix %prefix)) (mes-use-module (mescc mescc)))
(guile (guile
(use-modules (ice-9 syncase)) (define-macro (mes-use-module . rest) #t)))
(define %scheme "guile")
(define-macro (mes-use-module . rest) #t)
(module-define! (resolve-module '(language c99 compiler)) '%prefix %prefix)))
(define guile? (equal? %scheme "guile"))
(mes-use-module (mes guile))
(mes-use-module (mes getopt-long))
(mes-use-module (mes pretty-print))
(mes-use-module (language c99 info))
(mes-use-module (language c99 compiler))
(mes-use-module (mes display))
(mes-use-module (mes elf))
(mes-use-module (mes M1))
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-26))
(format (current-error-port) "mescc[~a]...\n" %scheme) (format (current-error-port) "mescc[~a]...\n" %scheme)
(define (parse-opts args) (define (parse-opts args)
(let* ((option-spec (let* ((option-spec
'((c (single-char #\c)) '((assemble (single-char #\c))
(compile (single-char #\S))
(define (single-char #\D) (value #t)) (define (single-char #\D) (value #t))
(E (single-char #\E)) (debug-info (single-char #\g))
(g (single-char #\g))
(help (single-char #\h)) (help (single-char #\h))
(include (single-char #\I) (value #t)) (include (single-char #\I) (value #t))
(o (single-char #\o) (value #t)) (library (single-char #\l) (value #t))
(preprocess (single-char #\E))
(output (single-char #\o) (value #t))
(version (single-char #\V)) (version (single-char #\V))
(verbose (single-char #\v))
(write (single-char #\w) (value #t)))) (write (single-char #\w) (value #t))))
(options (getopt-long args option-spec)) (options (getopt-long args option-spec))
(help? (option-ref options 'help #f)) (help? (option-ref options 'help #f))
@ -113,13 +93,15 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' scripts/mescc
(and (or help? usage?) (and (or help? usage?)
(format (or (and usage? (current-error-port)) (current-output-port)) "\ (format (or (and usage? (current-error-port)) (current-output-port)) "\
Usage: mescc [OPTION]... FILE... Usage: mescc [OPTION]... FILE...
-c compile and assemble, but do not link -c preprocess, compile and assemble only; do not link
-D DEFINE define DEFINE -D DEFINE[=VALUE] define DEFINE [VALUE=1]
-E preprocess only; do not compile, assemble or link -E preprocess only; do not compile, assemble or link
-g add debug info [GDB, objdump] TODO: hex2 footer -g add debug info [GDB, objdump] TODO: hex2 footer
-h, --help display this help and exit -h, --help display this help and exit
-I DIR append DIR to include path -I DIR append DIR to include path
-l LIBNAME link with LIBNAME
-o FILE write output to FILE -o FILE write output to FILE
-S preprocess and compile only; do not assemble or link
-v, --version display version and exit -v, --version display version and exit
-w,--write=TYPE dump Nyacc AST using TYPE {pretty-print,write} -w,--write=TYPE dump Nyacc AST using TYPE {pretty-print,write}
@ -132,76 +114,18 @@ Environment variables:
(exit (or (and usage? 2) 0))) (exit (or (and usage? 2) 0)))
options))) options)))
(define (read-object file)
(let ((char (with-input-from-file file read-char)))
(if (eq? char #\#) (error "hex2 format not supported:" file)))
(with-input-from-file file read))
(define (main:ast->info file)
(let ((ast (with-input-from-file file read)))
(c99-ast->info ast)))
(define (source->ast write defines includes)
(lambda (file)
(with-input-from-file file
(lambda ()
(write (c99-input->ast #:defines defines #:includes includes))))))
(define (source->info defines includes)
(lambda (file)
(with-input-from-file file
(lambda ()
((c99-input->info #:defines defines #:includes includes))))))
(define (ast? o)
(or (string-suffix? ".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? "-o" o)))
(define (main args) (define (main args)
(let* ((options (parse-opts args)) (let* ((options (parse-opts args))
(files (option-ref options '() '())) (options (acons 'prefix %prefix options))
(file (car files)) (preprocess? (option-ref options 'preprocess #f))
(file-name (car (string-split (basename file) #\.))) (compile? (option-ref options 'compile #f))
(preprocess? (option-ref options 'E #f)) (assemble? (option-ref options 'assemble #f))
(compile? (option-ref options 'c #f)) (verbose? (option-ref options 'verbose (getenv "MES_DEBUG"))))
(debug-info? (option-ref options 'g #f)) (when verbose?
(asts (filter ast? files))
(objects (filter object? files))
(sources (filter (cut string-suffix? ".c" <>) files))
(base (substring file (1+ (or (string-rindex file #\/) -1)) (- (string-length file) 2)))
(out (option-ref options 'o (cond (compile? (string-append base ".o"))
(preprocess? (string-append base ".E"))
(else "a.out"))))
(multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o)))))
(defines (reverse (filter-map (multi-opt 'define) options)))
(includes (reverse (filter-map (multi-opt 'include) options)))
(pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
(pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write)))
(when (getenv "MES_DEBUG")
(setenv "NYACC_TRACE" "yes") (setenv "NYACC_TRACE" "yes")
(format (current-error-port) "options=~s\n" options) (format (current-error-port) "options=~s\n" options))
(format (current-error-port) "output: ~a\n" out)) (cond (preprocess? (mescc:preprocess options))
(if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files)) (compile? (mescc:compile options))
(with-output-to-file out (assemble? (mescc:assemble options))
(lambda () (else (mescc:link options)))))
(if (and (not compile?)
(not preprocess?)) (set-port-encoding! (current-output-port) "ISO-8859-1"))
(cond ((pair? objects) (let ((objects (map read-object objects)))
(if compile? (objects->M1 file-name objects)
(objects->elf file objects))))
((pair? asts) (let* ((infos (map main:ast->info asts))
(objects (map info->object infos)))
(if compile? (objects->M1 file-name objects)
(objects->elf file objects))))
((pair? sources) (if preprocess? (map (source->ast pretty-print/write defines includes) sources)
(let* ((infos (map (source->info defines includes) sources))
(objects (map info->object infos)))
(if compile? (objects->M1 file-name objects)
(objects->elf file objects))))))))))
'done 'done