diff --git a/.gitignore b/.gitignore index 29fc9994..72179c13 100644 --- a/.gitignore +++ b/.gitignore @@ -8,12 +8,13 @@ *.0-guile *.0-hex2 *.E -*.M1 +*.S +*.o +*.blood-elf *.gcc *.guile -*.hex2 -*.hex2-o *.log +*.gcc-o *.mes-o *.mes-stdout *.mini-M1 @@ -32,8 +33,8 @@ /src/*.h /src/*.i +/src/mes -*.o /.config.make /.store /.tarball-version @@ -59,4 +60,3 @@ /doc/fosdem/fosdem.tex /doc/fosdem/fosdem.toc /doc/fosdem/fosdem.*vrb - diff --git a/AUTHORS b/AUTHORS index 757e0f40..c3f0bcd9 100644 --- a/AUTHORS +++ b/AUTHORS @@ -12,9 +12,6 @@ List of imported files Based on Guile ECMAScript module/language/c/lexer.mes -Included verbatim from GNU Guix -build-aux/compile-all.scm - Included verbatim from gnulib build-aux/gitlog-to-changelog diff --git a/GNUmakefile b/GNUmakefile index ba7196ef..820b2729 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -38,7 +38,7 @@ install: .config.make: ./configure -seed: +seed: all-go cd $(MES_SEED) && git reset --hard HEAD MES=$(GUILE) GUILE=$(GUILE) SEED=1 build-aux/build-mes.sh cd $(MES_SEED) && MES_PREFIX=$(PWD) ./refresh.sh diff --git a/build-aux/build-cc.sh b/build-aux/build-cc.sh index b147c001..0672c07a 100755 --- a/build-aux/build-cc.sh +++ b/build-aux/build-cc.sh @@ -18,7 +18,11 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -ex +set -e + +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi export CC CFLAGS CPPFLAGS @@ -46,7 +50,7 @@ build-aux/mes-snarf.scm src/posix.c build-aux/mes-snarf.scm src/reader.c build-aux/mes-snarf.scm src/vector.c -NOLINK=1 sh build-aux/cc.sh lib/mini-libc-gcc +NOLINK=1 sh build-aux/cc.sh lib/libc-mini-gcc NOLINK=1 sh build-aux/cc.sh lib/libc-gcc NOLINK=1 sh build-aux/cc.sh lib/libc+tcc-gcc diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 00834fbc..75e826cc 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -18,23 +18,51 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -ex +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi export GUILE GUILE=${GUILE-$(command -v guile)} +GUILE_TOOLS=${GUILE_TOOLS-$(command -v guile-tools)} + +set -e SCM_FILES=" -language/c99/compiler.scm -language/c99/info.scm -mes/as-i386.scm -mes/as.scm -mes/bytevectors.scm -mes/elf.scm -mes/guile.scm -mes/test.scm -mes/M1.scm" +guile/mes/guile.scm +guile/mes/misc.scm +guile/mes/test.scm +guile/mescc/M1.scm +guile/mescc/as.scm +guile/mescc/bytevectors.scm +guile/mescc/compile.scm +guile/mescc/i386/as.scm +guile/mescc/info.scm +guile/mescc/mescc.scm +guile/mescc/preprocess.scm +" export srcdir=. export host=$($GUILE -c "(display %host-type)") -cd guile -$GUILE --no-auto-compile -L . -C . -s ../build-aux/compile-all.scm $SCM_FILES + +#$GUILE --no-auto-compile -L guile -C guile -s build-aux/compile-all.scm $SCM_FILES + +for i in $SCM_FILES; do + go=${i%%.scm}.go + if [ $i -nt $go ]; then + echo " GUILEC $i" + $GUILE_TOOLS compile -L guile -L scripts -o $go $i + fi +done + +SCRIPTS=" +scripts/mescc +" + +for i in $SCRIPTS; do + go=${i%%.scm}.go + if [ $i -nt $go ]; then + echo " GUILEC $i" + $GUILE_TOOLS compile -L guile -L scripts -o $go $i + fi +done diff --git a/build-aux/build-mes.sh b/build-aux/build-mes.sh index 1bfac16e..5ed83961 100755 --- a/build-aux/build-mes.sh +++ b/build-aux/build-mes.sh @@ -18,12 +18,19 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -x +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi export BLOOD_ELF GUILE HEX2 M1 MES MESCC export M1FLAGS HEX2FLAGS PREPROCESS export MES_SEED MES_ARENA +GUILE=${GUILE-guile} +if [ -z "$GUILE" -o "$GUILE" = "true" ] || ! command -v $GUILE > /dev/null; then + GUILE=src/mes +fi + HEX2=${HEX2-hex2} M1=${M1-M1} BLOOD_ELF=${BLOOD_ELF-blood-elf} @@ -50,55 +57,58 @@ if [ -d "$MES_SEED" ]; then $M1FLAGS\ -f stage0/x86.M1\ -f $MES_SEED/crt1.M1\ - -o lib/crt1.hex2 + -o lib/crt1.o $M1\ $M1FLAGS\ -f stage0/x86.M1\ -f $MES_SEED/libc-mes.M1\ - -o lib/libc-mes.hex2 + -o lib/libc-mes.o $M1\ --LittleEndian\ --Architecture=1\ -f stage0/x86.M1\ -f $MES_SEED/mes.M1\ - -o src/mes.hex2 + -o src/mes.o $BLOOD_ELF\ -f stage0/x86.M1\ -f $MES_SEED/mes.M1\ -f $MES_SEED/libc-mes.M1\ - -o src/mes.blood-elf.M1 + -o src/mes.S.blood-elf $M1\ --LittleEndian\ --Architecture=1\ - -f src/mes.blood-elf.M1\ - -o src/mes.blood-elf.hex2 + -f src/mes.S.blood-elf\ + -o src/mes.o.blood-elf $HEX2\ $HEX2FLAGS\ -f stage0/elf32-header.hex2\ - -f lib/crt1.hex2\ - -f lib/libc-mes.hex2\ - -f src/mes.hex2\ - -f src/mes.blood-elf.hex2\ + -f lib/crt1.o\ + -f lib/libc-mes.o\ + -f src/mes.o\ + -f src/mes.o.blood-elf\ --exec_enable\ -o src/mes.seed-out cp src/mes.seed-out src/mes - $M1\ $M1FLAGS\ -f stage0/x86.M1\ -f $MES_SEED/libc+tcc-mes.M1\ - -o src/libc+tcc-mes.hex2 + -o lib/libc+tcc-mes.o fi PREPROCESS=1 NOLINK=1 sh build-aux/cc-mes.sh lib/crt1 -NOLINK=1 sh build-aux/cc-mes.sh lib/mini-libc-mes +NOLINK=1 sh build-aux/cc-mes.sh lib/libc-mini-mes NOLINK=1 sh build-aux/cc-mes.sh lib/libc-mes NOLINK=1 sh build-aux/cc-mes.sh lib/libc+tcc-mes +cp lib/crt1.mes-o lib/crt1.o +cp lib/libc-mini-mes.mes-o lib/libc-mini-mes.o +cp lib/libc-mes.mes-o lib/libc-mes.o +cp lib/libc+tcc-mes.mes-o lib/libc+tcc-mes.o + [ -n "$SEED" ] && exit 0 -GUILE=src/mes MES_ARENA=${MES_ARENA-30000000} sh build-aux/mes-snarf.scm --mes src/gc.c sh build-aux/mes-snarf.scm --mes src/lib.c @@ -108,10 +118,10 @@ sh build-aux/mes-snarf.scm --mes src/posix.c sh build-aux/mes-snarf.scm --mes src/reader.c sh build-aux/mes-snarf.scm --mes src/vector.c -# sh build-aux/cc-mes.sh scaffold/main -# sh build-aux/cc-mes.sh scaffold/hello -# sh build-aux/cc-mes.sh scaffold/argv -# sh build-aux/cc-mes.sh scaffold/malloc +sh build-aux/cc-mes.sh scaffold/main +sh build-aux/cc-mes.sh scaffold/hello +sh build-aux/cc-mes.sh scaffold/argv +sh build-aux/cc-mes.sh scaffold/malloc ##sh build-aux/cc-mes.sh scaffold/micro-mes ##sh build-aux/cc-mes.sh scaffold/tiny-mes # sh build-aux/cc-mes.sh scaffold/mini-mes diff --git a/build-aux/build-mlibc.sh b/build-aux/build-mlibc.sh index 1739cf63..5b2a2150 100755 --- a/build-aux/build-mlibc.sh +++ b/build-aux/build-mlibc.sh @@ -18,7 +18,11 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -ex +set -e + +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi export CC32 CPPFLAGS C32FLAGS @@ -59,7 +63,7 @@ C32FLAGS=${C32FLAGS-" "} NOLINK=1 sh build-aux/cc-mlibc.sh lib/crt1 -NOLINK=1 sh build-aux/cc-mlibc.sh lib/mini-libc-gcc +NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-mini-gcc NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc-gcc NOLINK=1 sh build-aux/cc-mlibc.sh lib/libc+tcc-gcc diff --git a/build-aux/cc-mes.sh b/build-aux/cc-mes.sh index 5836ddb6..d1dad871 100755 --- a/build-aux/cc-mes.sh +++ b/build-aux/cc-mes.sh @@ -18,16 +18,16 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -x +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi export BLOOD_ELF GUILE HEX2 M1 MES MESCC export M1FLAGS HEX2FLAGS PREPROCESS -export MES_SEED MES_ARENA HEX2=${HEX2-hex2} M1=${M1-M1} BLOOD_ELF=${BLOOD_ELF-blood-elf} -MES_SEED=${MES_SEED-../mes-seed} MESCC=${MESCC-$(command -v mescc)} [ -z "$MESCC" ] && MESCC=scripts/mescc MES=${MES-$(command -v mes)} @@ -41,67 +41,32 @@ CPPFLAGS=${CPPFLAGS-" -I lib -I include "} +MESCCFLAGS=${MESCCFLAGS-" +"} -MESCCLAGS=${MESCCFLAGS-" -"} -LIBC=${LIBC-lib/libc} -M1FLAGS=${M1FLAGS-" ---LittleEndian ---Architecture=1 -"} -HEX2FLAGS=${HEX2FLAGS-" ---LittleEndian ---Architecture=1 ---BaseAddress=0x1000000 -"} +if [ -n "$BUILD_DEBUG" ]; then + MESCCFLAGS="$MESCCFLAGS -v" +fi c=$1 set -e if [ -n "$PREPROCESS" ]; then - sh -x $MESCC\ - -E\ - $CPPFLAGS\ - $MESCCFLAGS\ - -o "$c".E\ - "$c".c - sh -x $MESCC\ - -c\ - -o "$c".M1\ - "$c".E + sh $MESCC $MESCCFLAGS $CPPFLAGS -E "$c".c + sh $MESCC $MESCCFLAGS -S "$c".E + sh $MESCC $MESCCFLAGS -c -o "$c".mes-o "$c".S + if [ -z "$NOLINK" ]; then + sh $MESCC $MESCCFLAGS -o "$c".mes-out "$c".mes-o $MESCCLIBS + fi +elif [ -n "$COMPILE" ]; then + sh $MESCC $MESCCFLAGS $CPPFLAGS -S "$c".c + sh $MESCC $MESCCFLAGS -c -o "$c".mes-o "$c".S + if [ -z "$NOLINK" ]; then + sh $MESCC $MESCCFLAGS -o "$c".mes-out "$c".mes-o $MESCCLIBS + fi +elif [ -z "$NOLINK" ]; then + sh $MESCC $MESCCFLAGS $CPPFLAGS -o "$c".mes-out "$c".c $MESCCLIBS else - sh -x $MESCC\ - -c\ - $CPPFLAGS\ - $MESCCFLAGS\ - -o "$c".M1\ - "$c".c -fi - -$M1\ - $M1FLAGS\ - -f stage0/x86.M1\ - -f "$c".M1\ - -o "$c".hex2 - -if [ -z "$NOLINK" ]; then - $BLOOD_ELF\ - -f stage0/x86.M1\ - -f "$c".M1\ - -f $LIBC-mes.M1\ - -o "$c".blood-elf-M1 - $M1\ - $M1FLAGS\ - -f "$c".blood-elf-M1\ - -o "$c".blood-elf-hex2 - $HEX2\ - $HEX2FLAGS\ - -f stage0/elf32-header.hex2\ - -f lib/crt1.hex2\ - -f $LIBC-mes.hex2\ - -f "$c".hex2\ - -f "$c".blood-elf-hex2\ - --exec_enable\ - -o "$c".mes-out + sh $MESCC $MESCCFLAGS $CPPFLAGS -c -o "$c".mes-out "$c".c fi diff --git a/build-aux/cc-mlibc.sh b/build-aux/cc-mlibc.sh index 4c8190f1..985db1b4 100755 --- a/build-aux/cc-mlibc.sh +++ b/build-aux/cc-mlibc.sh @@ -18,7 +18,11 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -ex +set -e + +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi CPPFLAGS=${CPPFLAGS-" -D VERSION=\"$VERSION\" @@ -56,5 +60,6 @@ if [ -z "$NOLINK" ]; then -o "$c".mlibc-out\ lib/crt1.mlibc-o\ "$c".mlibc-o\ - $LIBC-gcc.mlibc-o + $LIBC-gcc.mlibc-o\ + $CC32LIBS fi diff --git a/build-aux/cc.sh b/build-aux/cc.sh index 0929a205..b85ed2d5 100755 --- a/build-aux/cc.sh +++ b/build-aux/cc.sh @@ -18,7 +18,11 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -ex +set -e + +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi CPPFLAGS=${CPPFLAGS-" -D VERSION=\"$VERSION\" diff --git a/build-aux/check-boot.sh b/build-aux/check-boot.sh index f418c935..34844314 100755 --- a/build-aux/check-boot.sh +++ b/build-aux/check-boot.sh @@ -18,12 +18,17 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -e export GUILE MES -GUILE=${GUILE-guile} MES=${MES-./src/mes} +GUILE=${GUILE-guile} +if ! command -v $GUILE > /dev/null; then + GUILE=true +fi + +set -e + tests=" 00-zero.scm diff --git a/build-aux/check-mescc.sh b/build-aux/check-mescc.sh index dbf65fb2..4546cda0 100755 --- a/build-aux/check-mescc.sh +++ b/build-aux/check-mescc.sh @@ -18,9 +18,15 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi + export BLOOD_ELF GUILE HEX2 M1 MES MESCC -export M1FLAGS HEX2FLAGS PREPROCESS LIBC +export M1FLAGS HEX2FLAGS PREPROCESS export MES_ARENA MES_PREFIX MES_SEED +export BUILD_DEBUG +export CC32LIBS MESCCLIBS MES=${MES-src/mes} MESCC=${MESCC-scripts/mescc} @@ -36,6 +42,9 @@ MESCC=${MESCC-$(command -v mescc)} MES=${MES-$(command -v mes)} [ -z "$MES" ] && MES=src/mes +if ! command -v $GUILE > /dev/null; then + GUILE=true +fi tests=" t @@ -135,14 +144,18 @@ expect=$(echo $broken | wc -w) pass=0 fail=0 total=0 +MESCCLIBS= LIBC=libc/libc for t in $tests; do if [ -z "${t/[012][0-9]-*/}" ]; then - LIBC=lib/mini-libc; + LIBC="lib/libc-mini" + MESCCLIBS="-l c-mini" elif [ -z "${t/8[0-9]-*/}" ]; then - LIBC=lib/libc+tcc; + LIBC="lib/libc+tcc" + MESCCLIBS="-l c+tcc" else - LIBC=lib/libc; + LIBC=libc/libc + MESCCLIBS= fi sh build-aux/test.sh "scaffold/tests/$t" &> scaffold/tests/"$t".log r=$? diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm deleted file mode 100644 index 013904b0..00000000 --- a/build-aux/compile-all.scm +++ /dev/null @@ -1,159 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer -;;; Copyright © 2016, 2017 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(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-mtimego 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-mtimemes file))) ; FIXME: try to respect (include-from-path ".mes") - (and (file-exists? mes) - (file-mtimemodule file) - (let* ((relative (relative-file file)) - (module-path (string-drop-right relative 4))) - (map string->symbol - (string-split module-path #\/)))) - -;;; To work around (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: diff --git a/build-aux/test.sh b/build-aux/test.sh index 5908f7bc..d8ae6e7a 100755 --- a/build-aux/test.sh +++ b/build-aux/test.sh @@ -18,9 +18,11 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -x +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi -export LIBC +export LIBC MESCCLIBS GUILE=${GUILE-$MES} DIFF=${DIFF-$(command -v diff)} diff --git a/build.sh b/build.sh index 2e2525ea..f5f89d01 100755 --- a/build.sh +++ b/build.sh @@ -18,12 +18,16 @@ # You should have received a copy of the GNU General Public License # along with Mes. If not, see . -set -x +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi + # dash does not export foo=${foo-bar} for some values export CC CC32 GUILE MESCC MES_SEED export MES_ARENA MES_DEBUG export PREFIX DATADIR MODULEDIR export CPPFLAGS CFLAGS C32FLAGS MESCCFLAGS +export BUILD_DEBUG CC=${CC-$(command -v gcc)} CC32=${CC32-$(command -v i686-unknown-linux-gnu-gcc)} @@ -31,7 +35,7 @@ MESCC=${MESCC-$(command -v mescc)} MES_SEED=${MES_SEED-../mes-seed} GUILE=${GUILE-$(command -v guile)} MES_ARENA=${MES_ARENA-300000000} -MES_DEBUG=${MES_DEBUG-2} +MES_DEBUG=${MES_DEBUG-1} PREFIX=${PREFIX-/usr/local} DATADIR=${DATADIR-$PREFIX/share/mes} diff --git a/check.sh b/check.sh index 9c8b2fab..ce659332 100755 --- a/check.sh +++ b/check.sh @@ -20,10 +20,17 @@ export CC32 export GUILE MES MES_ARENA +export BUILD_DEBUG + CC32=${CC32-$(command -v i686-unknown-linux-gnu-gcc)} GUILE=${GUILE-guile} MES=${MES-src/mes} -MES_ARENA=${MES_ARENA-100000000} +MES_ARENA=${MES_ARENA-300000000} +PREFIX= + +if ! command -v $GUILE > /dev/null; then + GUILE=true +fi set -e bash build-aux/check-boot.sh diff --git a/guile/mescc b/guile/mescc new file mode 120000 index 00000000..540fb2db --- /dev/null +++ b/guile/mescc @@ -0,0 +1 @@ +../module/mescc \ No newline at end of file diff --git a/lib/libc-gcc.c b/lib/libc-gcc.c index b69489f0..1bcc0a7c 100644 --- a/lib/libc-gcc.c +++ b/lib/libc-gcc.c @@ -29,8 +29,8 @@ #include #include -#include -#include +#include +#include #include #include diff --git a/lib/libc-mes.c b/lib/libc-mes.c index 92136b0c..91fde8b2 100644 --- a/lib/libc-mes.c +++ b/lib/libc-mes.c @@ -25,7 +25,7 @@ void _env (); -#include -#include +#include +#include #include #include diff --git a/lib/mini-libc-gcc.c b/lib/libc-mini-gcc.c similarity index 94% rename from lib/mini-libc-gcc.c rename to lib/libc-mini-gcc.c index 2702168b..5eff7e54 100644 --- a/lib/mini-libc-gcc.c +++ b/lib/libc-mini-gcc.c @@ -18,5 +18,5 @@ * along with Mes. If not, see . */ -#include -#include +#include +#include diff --git a/lib/mini-libc-mes.c b/lib/libc-mini-mes.c similarity index 94% rename from lib/mini-libc-mes.c rename to lib/libc-mini-mes.c index 5aa1b856..bc1eadde 100644 --- a/lib/mini-libc-mes.c +++ b/lib/libc-mini-mes.c @@ -18,5 +18,5 @@ * along with Mes. If not, see . */ -#include -#include +#include +#include diff --git a/lib/mini-libc.c b/lib/libc-mini.c similarity index 100% rename from lib/mini-libc.c rename to lib/libc-mini.c diff --git a/lib/mini-linux-gcc.c b/lib/linux-mini-gcc.c similarity index 100% rename from lib/mini-linux-gcc.c rename to lib/linux-mini-gcc.c diff --git a/lib/mini-linux-mes.c b/lib/linux-mini-mes.c similarity index 100% rename from lib/mini-linux-mes.c rename to lib/linux-mini-mes.c diff --git a/module/language/c99/compiler.scm b/module/language/c99/compiler.scm deleted file mode 100644 index 0604bfcd..00000000 --- a/module/language/c99/compiler.scm +++ /dev/null @@ -1,61 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen -;;; -;;; This file is part of Mes. -;;; -;;; Mes is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; Mes is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Mes. If not, see . - -;;; Commentary: - -;;; Code: - -(define-module (language c99 compiler) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-26) - #:use-module (system base pmatch) - #:use-module (ice-9 optargs) - #:use-module (ice-9 pretty-print) - #:use-module (nyacc lang c99 parser) - ;;#:use-module (nyacc lang c99 pprint) - #:use-module (mes guile) - #:use-module (mes as) - #:use-module (mes as-i386) - #:use-module (mes elf) - #:use-module (mes M1) - #:use-module (language c99 info) - #:export (c99-ast->info - c99-input->ast - c99-input->elf - c99-input->info - c99-input->object - info->object)) - -(cond-expand - (guile-2 - (use-modules (nyacc lang c99 pprint))) - (guile - (debug-set! stack 0) - (use-modules (ice-9 optargs)) - (use-modules (ice-9 syncase))) - ;; guile-1.8 does not have (sxml match), short-circuit me - (define* (pretty-print-c99 tree - #:optional (port (current-output-port)) - #:key ugly per-line-prefix (basic-offset 2)) - (write tree port)) - (mes)) - -(include-from-path "language/c99/compiler.mes") diff --git a/module/mes/M1.scm b/module/mes/M1.scm deleted file mode 100644 index ab522cae..00000000 --- a/module/mes/M1.scm +++ /dev/null @@ -1,44 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen -;;; -;;; This file is part of Mes. -;;; -;;; Mes is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; Mes is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Mes. If not, see . - -;;; Commentary: - -;;; Code: - -(define-module (mes M1) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (system base pmatch) - #:use-module (mes guile) - #:use-module (mes as) - #:use-module (mes elf) - #:use-module (language c99 info) - #:export (object->M1 - objects->M1 - object->elf - objects->elf)) - -(cond-expand - (guile-2) - (guile - (use-modules (ice-9 syncase))) - (mes)) - -(include-from-path "mes/M1.mes") diff --git a/module/mes/as-i386.scm b/module/mes/as-i386.scm deleted file mode 100644 index d38ee7e0..00000000 --- a/module/mes/as-i386.scm +++ /dev/null @@ -1,172 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen -;;; -;;; This file is part of Mes. -;;; -;;; Mes is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; Mes is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Mes. If not, see . - -;;; Commentary: - -;;; 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:base+value - i386:base->accu - i386:base->accu-mem - i386:base->label - i386:base-mem->accu-mem - i386:base-mem+n->accu - i386:base-mem->accu - i386:base-sub - i386:byte-accu->base-mem - i386:word-accu->base-mem - i386:byte-base->accu-mem - i386:byte-base->accu-mem+n - i386:byte-base-mem->accu - i386:byte-base-sub - i386:byte-local->base - i386:byte-mem->accu - i386:word-mem->accu - i386:byte-mem->base - i386:byte-sub-base - i386:byte-test-base - i386:call-accu - i386:call-label - i386:formal - i386:function-locals - i386:function-preamble - i386:jump - i386:jump - i386:jump-a - i386:jump-ae - i386:jump-b - i386:jump-be - i386:jump-byte-z - i386:jump-g - i386:jump-ge - i386:jump-l - i386:jump-le - i386:jump-nz - i386:jump-z - i386:label->accu - i386:label->base - i386:label-mem->accu - i386:label-mem->base - i386:label-mem-add - i386:local->accu - i386:local->base - i386:local-add - i386:local-address->accu - i386:local-address->accu - i386:local-address->base - i386:local-ptr->accu - i386:local-ptr->base - i386:local-test - i386:mem+n->accu - i386:byte-mem+n->accu - i386:word-mem+n->accu - i386:mem->accu - i386:mem->base - i386:nop - i386:nz->accu - i386:pop-accu - i386:pop-base - i386:push-accu - i386:push-base - i386:push-byte-local-de-de-ref - i386:push-byte-local-de-ref - i386:push-word-local-de-ref - i386:push-label - i386:push-label-mem - i386:push-local - i386:push-local-address - i386:push-local-de-ref - i386:ret - i386:ret-local - i386:sub-base - i386:test-base - i386:value->accu - i386:value->accu-mem - i386:value->accu-mem+n - i386:value->base - i386:value->label - i386:value->local - i386:xor-accu - i386:xor-zf - i386:g?->accu - i386:ge?->accu - i386:l?->accu - i386:le?->accu - i386:a?->accu - i386:ae?->accu - i386:b?->accu - i386:be?->accu - i386:z->accu - i386:byte-accu - i386:signed-byte-accu - i386:word-accu - i386:signed-word-accu - )) - -(cond-expand - (guile-2) - (guile - (use-modules (ice-9 syncase))) - (mes)) - -(include-from-path "mes/as-i386.mes") diff --git a/module/mes/boot-0.scm b/module/mes/boot-0.scm index 8c987c46..32296a7c 100644 --- a/module/mes/boot-0.scm +++ b/module/mes/boot-0.scm @@ -152,7 +152,9 @@ (define-macro (load file) (list 'begin - (list 'if (list getenv "MES_DEBUG") + (list 'if (list 'and (list getenv "MES_DEBUG") + (list not (list equal2? (list getenv "MES_DEBUG") "0")) + (list not (list equal2? (list getenv "MES_DEBUG") "1"))) (list 'begin (list core:display-error ";;; read ") (list core:display-error file) @@ -190,7 +192,9 @@ "@VERSION@")) (define (effective-version) %version) -(if (getenv "MES_DEBUG") +(if (list 'and (list getenv "MES_DEBUG") + (list not (list equal2? (list getenv "MES_DEBUG") "0")) + (list not (list equal2? (list getenv "MES_DEBUG") "1"))) (begin (core:display-error ";;; %moduledir=") (core:display-error %moduledir) @@ -295,7 +299,7 @@ remaining arguments as the value of (command-line). (set! %argv files) (set-current-input-port port))) ((and (null? files) tty?) - + (mes-use-module (mes repl)) (set-current-input-port 0) (repl)) diff --git a/module/mes/guile.mes b/module/mes/guile.mes index c13e8930..c50925a8 100644 --- a/module/mes/guile.mes +++ b/module/mes/guile.mes @@ -22,13 +22,16 @@ ;;; Code: +(mes-use-module (srfi srfi-13)) + (define-macro (cond-expand-provide . rest) #t) (define-macro (include-from-path file) (let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:)))) - (if (getenv "MES_DEBUG") - ;;(format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path) - (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n"))) + (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number)) + (core:display-error (string-append "include-from-path: " file "\n"))) + ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))) + (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n"))) (if (null? path) (error "include-from-path: not found: " file) (let ((file (string-append (car path) "/" file))) (if (access? file R_OK) `(load ,file) @@ -37,7 +40,6 @@ (mes-use-module (mes catch)) (mes-use-module (mes posix)) (mes-use-module (srfi srfi-16)) -(mes-use-module (srfi srfi-26)) (mes-use-module (mes display)) (if #t ;;(not (defined? 'read-string)) @@ -46,7 +48,7 @@ (if (eq? c #\*eof*) '() (cons c (read-string (read-char))))) (let ((string (list->string (read-string (read-char))))) - (if (and=> (getenv "MES_DEBUG") (compose (cut > <> 3) string->number)) + (if (and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 3)) string->number)) (core:display-error (string-append "drained: `" string "'\n"))) string))) @@ -147,4 +149,3 @@ (with-output-to-string (lambda () (simple-format lst rest)))))) (define format simple-format) - diff --git a/module/mes/elf.scm b/module/mes/mescc.mes similarity index 74% rename from module/mes/elf.scm rename to module/mes/mescc.mes index 22da8fbb..cb8ff2aa 100644 --- a/module/mes/elf.scm +++ b/module/mes/mescc.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -22,14 +22,4 @@ ;;; Code: -(define-module (mes elf) - #:use-module (mes guile) - #:export (M1->elf)) - -(cond-expand - (guile-2) - (guile - (use-modules (ice-9 syncase))) - (mes)) - -(include-from-path "mes/elf.mes") +(include-from-path "mes/mescc.scm") diff --git a/module/mes/as.scm b/module/mes/misc.mes similarity index 64% rename from module/mes/as.scm rename to module/mes/misc.mes index c7cb83b7..6988ce84 100644 --- a/module/mes/as.scm +++ b/module/mes/misc.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -18,23 +18,4 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -;;; Commentary: - -;;; Code: - -(define-module (mes as) - #:use-module (srfi srfi-1) - #:use-module (mes guile) - #:use-module (mes bytevectors) - #:export (dec->hex - int->bv8 - int->bv16 - int->bv32)) - -(cond-expand - (guile-2) - (guile - (use-modules (ice-9 syncase))) - (mes)) - -(include-from-path "mes/as.mes") +(include-from-path "mes/misc.scm") diff --git a/module/mes/misc.scm b/module/mes/misc.scm new file mode 100644 index 00000000..35c964e3 --- /dev/null +++ b/module/mes/misc.scm @@ -0,0 +1,65 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(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))))) diff --git a/module/mes/posix.mes b/module/mes/posix.mes index 5c039a60..1cacf70d 100644 --- a/module/mes/posix.mes +++ b/module/mes/posix.mes @@ -22,6 +22,8 @@ ;;; Code: +(mes-use-module (srfi srfi-13)) + (define R_OK 0) (define S_IRWXU #o700) diff --git a/module/mescc/M1.mes b/module/mescc/M1.mes new file mode 100644 index 00000000..057c5eb7 --- /dev/null +++ b/module/mescc/M1.mes @@ -0,0 +1,28 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(mes-use-module (srfi srfi-1)) +(mes-use-module (srfi srfi-26)) +(mes-use-module (mes misc)) +(mes-use-module (mes optargs)) +(mes-use-module (mes pmatch)) +(mes-use-module (mescc as)) +(mes-use-module (mescc info)) +(include-from-path "mescc/M1.scm") diff --git a/module/mes/M1.mes b/module/mescc/M1.scm similarity index 81% rename from module/mes/M1.mes rename to module/mescc/M1.scm index 107342ac..12941672 100644 --- a/module/mes/M1.mes +++ b/module/mescc/M1.scm @@ -1,7 +1,5 @@ -;;; -*-scheme-*- - ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -20,51 +18,31 @@ ;;; Commentary: -;;; M1.mes produces stage0' M1 object format +;;; M1.scm produces stage0' M1 assembly format ;;; Code: -(cond-expand - (guile) - (mes - (mes-use-module (srfi srfi-1)) - (mes-use-module (srfi srfi-26)) - (mes-use-module (mes as)) - (mes-use-module (mes elf)) - (mes-use-module (mes optargs)) - (mes-use-module (mes pmatch)) - (mes-use-module (language c99 info)))) +(define-module (mescc M1) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (system base pmatch) + #:use-module (mes misc) + #:use-module (mes guile) -(define (logf port string . rest) - (apply format (cons* port string rest)) - (force-output port) - #t) + #:use-module (mescc as) + #:use-module (mescc info) + #:export (info->M1 + infos->M1 + M1:merge-infos)) -(define (stderr string . rest) - (apply logf (cons* (current-error-port) string rest))) +(define (infos->M1 file-name infos) + (let ((info (fold M1:merge-infos (make ) infos))) + (info->M1 file-name info))) -(define (pke . stuff) - (newline (current-error-port)) - (display ";;; " (current-error-port)) - (write stuff (current-error-port)) - (newline (current-error-port)) - (car (last-pair stuff))) - -(define (objects->M1 file-name objects) - ((compose (cut object->M1 file-name <>) merge-objects) objects)) - -(define (object->elf file-name o) - ((compose M1->elf (cut object->M1 file-name <>)) o)) - -(define (objects->elf file-name objects) - ((compose M1->elf (cut object->M1 file-name <>) merge-objects) objects)) - -(define (merge-objects objects) - (let loop ((objects (cdr objects)) (object (car objects))) - (if (null? objects) object - (loop (cdr objects) - `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions))) - (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals)))))))) +(define (M1:merge-infos o info) + (clone info + #:functions (alist-add (.functions info) (.functions o)) + #:globals (alist-add (.globals info) (.globals o)))) (define (alist-add a b) (let* ((b-keys (map car b)) @@ -99,11 +77,10 @@ (display sep)) (loop (cdr o))))) -(define (object->M1 file-name o) - (stderr "dumping M1: object\n") - (let* ((functions (assoc-ref o 'functions)) +(define (info->M1 file-name o) + (let* ((functions (.functions o)) (function-names (map car functions)) - (globals (assoc-ref o 'globals)) + (globals (.globals o)) (global-names (map car globals)) (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names))) (define (string->label o) diff --git a/module/mes/elf.mes b/module/mescc/as.mes similarity index 80% rename from module/mes/elf.mes rename to module/mescc/as.mes index 481abf85..92d88e06 100644 --- a/module/mes/elf.mes +++ b/module/mescc/as.mes @@ -1,4 +1,4 @@ -<;;; -*-scheme-*- +;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen @@ -18,15 +18,6 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -;;; Commentary: - -;;; elf.mes - produce a i386 elf executable. - -;;; Code: - -(cond-expand - (guile) - (mes)) - -(define (M1->elf objects) - (error "->ELF support dropped, use M1")) +(mes-use-module (srfi srfi-1)) +(mes-use-module (mescc bytevectors)) +(include-from-path "mescc/as.scm") diff --git a/module/mes/as.mes b/module/mescc/as.scm similarity index 79% rename from module/mes/as.mes rename to module/mescc/as.scm index d6508a69..b4a85cdb 100644 --- a/module/mes/as.mes +++ b/module/mescc/as.scm @@ -1,7 +1,5 @@ -;;; -*-scheme-*- - ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -18,19 +16,14 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -;;; Commentary: - -;;; compiler.mes produces an i386 binary from the C produced by -;;; Nyacc c99. - -;;; Code: - -(cond-expand - (guile) - (guile-2) - (mes - (mes-use-module (srfi srfi-1)) - (mes-use-module (mes bytevectors)))) +(define-module (mescc as) + #:use-module (srfi srfi-1) + #:use-module (mes guile) + #:use-module (mescc bytevectors) + #:export (dec->hex + int->bv8 + int->bv16 + int->bv32)) (define (int->bv32 value) (let ((bv (make-bytevector 4))) diff --git a/module/mescc/bytevectors.mes b/module/mescc/bytevectors.mes new file mode 100644 index 00000000..da91c72a --- /dev/null +++ b/module/mescc/bytevectors.mes @@ -0,0 +1,21 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(include-from-path "mescc/bytevectors.scm") diff --git a/module/mes/bytevectors.mes b/module/mescc/bytevectors.scm similarity index 90% rename from module/mes/bytevectors.mes rename to module/mescc/bytevectors.scm index 2a19676b..b1cf14a3 100644 --- a/module/mes/bytevectors.mes +++ b/module/mescc/bytevectors.scm @@ -1,5 +1,3 @@ -;;; -*-scheme-*- - ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen ;;; @@ -20,10 +18,15 @@ ;;; Commentary: -;;; bytevectors.mes - ;;; Code: +(define-module (mescc bytevectors) + #:use-module (mes guile) + #:export (bytevector-u32-native-set! + bytevector-u16-native-set! + bytevector-u8-set! + make-bytevector)) + ;; rnrs compatibility (define (bytevector-u32-native-set! bv index value) (when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value)) diff --git a/module/mescc/compile.mes b/module/mescc/compile.mes new file mode 100644 index 00000000..702363c4 --- /dev/null +++ b/module/mescc/compile.mes @@ -0,0 +1,33 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(mes-use-module (srfi srfi-1)) +(mes-use-module (srfi srfi-13)) +(mes-use-module (srfi srfi-26)) +(mes-use-module (mes pmatch)) +(mes-use-module (mes optargs)) +(mes-use-module (mes misc)) +(mes-use-module (nyacc lang c99 pprint)) + +(mes-use-module (mescc as)) +(mes-use-module (mescc i386 as)) +(mes-use-module (mescc info)) +(mes-use-module (mescc M1)) +(include-from-path "mescc/compile.scm") diff --git a/module/language/c99/compiler.mes b/module/mescc/compile.scm similarity index 95% rename from module/language/c99/compiler.mes rename to module/mescc/compile.scm index 7af6c89f..b2e04a6f 100644 --- a/module/language/c99/compiler.mes +++ b/module/mescc/compile.scm @@ -1,5 +1,3 @@ -;;; -*-scheme-*- - ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen ;;; @@ -20,119 +18,48 @@ ;;; Commentary: -;;; compiler.mes produces an i386 binary from the C produced by -;;; Nyacc c99. - ;;; Code: -(cond-expand - (guile-2) - (guile) - (mes - (mes-use-module (srfi srfi-1)) - (mes-use-module (srfi srfi-26)) - (mes-use-module (mes pmatch)) - (mes-use-module (nyacc lang c99 parser)) - (mes-use-module (nyacc lang c99 pprint)) - (mes-use-module (mes as)) - (mes-use-module (mes as-i386)) - (mes-use-module (mes M1)) - (mes-use-module (mes optargs)) - (mes-use-module (language c99 info)))) +(define-module (mescc compile) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + #:use-module (system base pmatch) + #:use-module (ice-9 optargs) + #:use-module (ice-9 pretty-print) + #:use-module (nyacc lang c99 pprint) -(define (logf port string . rest) - (apply format (cons* port string rest)) - (force-output port) - #t) + #:use-module (mes guile) + #:use-module (mes misc) -(define (stderr string . rest) - (apply logf (cons* (current-error-port) string rest))) - -(define (pke . stuff) - (newline (current-error-port)) - (display ";;; " (current-error-port)) - (write stuff (current-error-port)) - (newline (current-error-port)) - (car (last-pair stuff))) - -(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "PREFIX") "") "@PREFIX@")) + #:use-module (mescc preprocess) + #:use-module (mescc info) + #:use-module (mescc as) + #:use-module (mescc i386 as) + #:use-module (mescc M1) + #:export (c99-ast->info + c99-input->info + c99-input->object)) (define mes? (pair? (current-module))) +(define* (c99-input->info #:key (prefix "") (defines '()) (includes '())) + (let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes))) + (c99-ast->info ast))) + +(define* (c99-ast->info o) + (stderr "compiling: input\n") + (let ((info (ast->info o (make #:types i386:type-alist)))) + (clean-info info))) + +(define (clean-info o) + (make + #:functions (filter (compose pair? function:text cdr) (.functions o)) + #:globals (.globals o))) + (define %int-size 4) (define %pointer-size %int-size) -(define* (c99-input->full-ast #:key (defines '()) (includes '())) - (let ((sys-include (if (equal? %prefix "") "include" (string-append %prefix "/share/include")))) - (parse-c99 - #:inc-dirs (append includes (cons* sys-include "include" "lib" (or (and=> (getenv "C_INCLUDE_PATH") (cut string-split <> #\:)) '()))) - #:cpp-defs `( - "NULL=0" - "__linux__=1" - "__i386__=1" - "POSIX=0" - "_POSIX_SOURCE=0" - "__MESC__=1" - ,(if mes? "__MESC_MES__=1" "__MESC_MES__=0") - ,@defines) - #:mode 'code))) - -(define (ast-strip-comment o) - (pmatch o - ((comment . ,comment) #f) - (((comment . ,comment) . ,t) (filter-map ast-strip-comment t)) - (((comment . ,comment) . ,cdr) cdr) - ((,car . (comment . ,comment)) car) - ((,h . ,t) (if (list? o) (filter-map ast-strip-comment o) - (cons (ast-strip-comment h) (ast-strip-comment t)))) - (_ o))) - -(define (ast-strip-const o) - (pmatch o - ((type-qual ,qual) (if (equal? qual "const") #f o)) - ((pointer (type-qual-list (type-qual ,qual)) . ,rest) - (if (equal? qual "const") `(pointer ,@rest) o)) - ((decl-spec-list (type-qual ,qual)) - (if (equal? qual "const") #f - `(decl-spec-list (type-qual ,qual)))) - ((decl-spec-list (type-qual ,qual) . ,rest) - (if (equal? qual "const") `(decl-spec-list ,@rest) - `(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest)))) - ((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest) - (if (equal? qual "const") `(decl-spec-list ,@rest) - `(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest)))) - ((,h . ,t) (if (list? o) (filter-map ast-strip-const o) - (cons (ast-strip-const h) (ast-strip-const t)))) - (_ o))) - -(define (clone o . rest) - (cond ((info? o) - (let ((types (.types o)) - (constants (.constants o)) - (functions (.functions o)) - (globals (.globals o)) - (locals (.locals o)) - (statics (.statics o)) - (function (.function o)) - (text (.text o)) - (post (.post o)) - (break (.break o)) - (continue (.continue o))) - (let-keywords rest - #f - ((types types) - (constants constants) - (functions functions) - (globals globals) - (locals locals) - (statics statics) - (function function) - (text text) - (post post) - (break break) - (continue continue)) - (make #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue)))))) - (define (ident->constant name value) (cons name value)) @@ -755,7 +682,11 @@ (define (ast->comment o) (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) " "))))) (define (accu*n info n) @@ -2496,32 +2427,3 @@ #:globals (append (.statics info) (.globals info)) #:statics '() #:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info)))))))))) - -;; exports - -(define* (c99-ast->info o) - (ast->info o (make #: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 #:types i386:type-alist)) - (ast (c99-input->ast #:defines defines #:includes includes)) - (foo (stderr "compiling: input\n")) - (info (ast->info ast info)) - (info (clone info #:text '() #:locals '()))) - info))) - -(define* (info->object o) - (stderr "compiling: object\n") - `((functions . ,(filter (compose pair? function:text cdr) (.functions o))) - (globals . ,(.globals o)))) - -(define* (c99-input->elf #:key (defines '()) (includes '())) - ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes)))) - -(define* (c99-input->object #:key (defines '()) (includes '())) - ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes)))) diff --git a/module/mescc/i386/as.mes b/module/mescc/i386/as.mes new file mode 100644 index 00000000..b5abb749 --- /dev/null +++ b/module/mescc/i386/as.mes @@ -0,0 +1,22 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(mes-use-module (mescc as)) +(include-from-path "mescc/i386/as.scm") diff --git a/module/mes/as-i386.mes b/module/mescc/i386/as.scm similarity index 81% rename from module/mes/as-i386.mes rename to module/mescc/i386/as.scm index 1b8c8f4f..797d62e4 100644 --- a/module/mes/as-i386.mes +++ b/module/mescc/i386/as.scm @@ -1,7 +1,5 @@ -;;; -*-scheme-*- - ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -20,15 +18,148 @@ ;;; Commentary: -;;; as-i386.mes defines i386 assembly +;;; define i386 assembly ;;; Code: -(cond-expand - (guile-2) - (guile) - (mes - (mes-use-module (mes as)))) +(define-module (mescc i386 as) + #:use-module (mes guile) + #:use-module (mescc 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: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) '(("nop"))) diff --git a/module/language/c99/info.mes b/module/mescc/info.mes similarity index 85% rename from module/language/c99/info.mes rename to module/mescc/info.mes index ec89743e..ea30e301 100644 --- a/module/language/c99/info.mes +++ b/module/mescc/info.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -24,5 +24,5 @@ (mes-use-module (srfi srfi-9)) (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") diff --git a/module/language/c99/info.scm b/module/mescc/info.scm similarity index 82% rename from module/language/c99/info.scm rename to module/mescc/info.scm index 84f1c3a9..267dc003 100644 --- a/module/language/c99/info.scm +++ b/module/mescc/info.scm @@ -1,5 +1,3 @@ -;;; -*-scheme-*- - ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen ;;; @@ -18,17 +16,20 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -;;; info.scm defines [Guile] record data types for compiler.mes +;;; Commentary: + +;;; info.scm defines [Guile] record data types for MesCC ;;; Code: -(define-module (language c99 info) +(define-module (mescc info) #:use-module (ice-9 optargs) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) #:export ( make + clone make- info? @@ -113,14 +114,6 @@ rank+= structured-type?)) -(cond-expand - (guile-2) - (guile - (use-modules (ice-9 syncase)) - (use-modules (ice-9 optargs))) - (mes - (mes-use-module (mes optargs)))) - (define-immutable-record-type (make- types constants functions globals locals statics function text post break continue) info? @@ -137,7 +130,36 @@ (continue .continue)) (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '())) - (make- types constants functions globals locals statics function text post break continue)) + (cond ((eq? o ) + (make- 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 #: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)) ;; (make-type 'enum 4 0 fields) diff --git a/module/mes/bytevectors.scm b/module/mescc/mescc.mes similarity index 64% rename from module/mes/bytevectors.scm rename to module/mescc/mescc.mes index c2415539..dde67dea 100644 --- a/module/mes/bytevectors.scm +++ b/module/mescc/mescc.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -18,21 +18,14 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -;;; 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: - -(define-module (mes bytevectors) - #:use-module (mes guile) - #:export (bytevector-u32-native-set! - bytevector-u16-native-set! - bytevector-u8-set! - make-bytevector)) - -(cond-expand - (guile-2) - (guile - (use-modules (ice-9 syncase))) - (mes)) - -(include-from-path "mes/bytevectors.mes") +(mes-use-module (mes guile)) +(mes-use-module (mescc preprocess)) +(mes-use-module (mescc compile)) +(mes-use-module (mescc M1)) +(include-from-path "mescc/mescc.scm") diff --git a/module/mescc/mescc.scm b/module/mescc/mescc.scm new file mode 100644 index 00000000..3e5b997c --- /dev/null +++ b/module/mescc/mescc.scm @@ -0,0 +1,232 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(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))) diff --git a/module/mescc/preprocess.mes b/module/mescc/preprocess.mes new file mode 100644 index 00000000..a2414d1f --- /dev/null +++ b/module/mescc/preprocess.mes @@ -0,0 +1,27 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(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") diff --git a/module/mescc/preprocess.scm b/module/mescc/preprocess.scm new file mode 100644 index 00000000..34252b3e --- /dev/null +++ b/module/mescc/preprocess.scm @@ -0,0 +1,87 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;;; Commentary: + +;;; 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))) diff --git a/module/srfi/srfi-1.mes b/module/srfi/srfi-1.mes index 62d47018..494a197e 100644 --- a/module/srfi/srfi-1.mes +++ b/module/srfi/srfi-1.mes @@ -131,10 +131,4 @@ (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") diff --git a/module/srfi/srfi-13.mes b/module/srfi/srfi-13.mes index 7da2d77c..82db4c3c 100644 --- a/module/srfi/srfi-13.mes +++ b/module/srfi/srfi-13.mes @@ -24,7 +24,6 @@ ;;; Code: -(mes-use-module (srfi srfi-1)) (mes-use-module (srfi srfi-14)) (define (string-join lst . delimiter+grammar) @@ -76,10 +75,12 @@ ((> n 0) (list->string (list-tail (string->list s) n))) (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) (cond ((zero? n) s) - ((> n 0) (let ((length (string-length s))) - (list->string (list-head (string->list s) (- length n))))) + ((> n 0) ((compose list->string (lambda (o) (drop-right o n)) string->list) s)) (else (error "string-drop-right: not supported: n=" n)))) (define (string-delete pred s) diff --git a/scripts/mescc b/scripts/mescc index 2c4c1bd9..c9d7da92 100755 --- a/scripts/mescc +++ b/scripts/mescc @@ -1,5 +1,14 @@ #! /bin/sh # -*-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) if [ '(' -z "$mes_p" -a -z "$MES" ')' -o "$MES" = "guile" -o "$MES" = "mes.guile" ]; then 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" "$@" else 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"} export MES_MODULEDIR exec ${MES-mes} -e '(mescc)' -s $0 "$@" - exit $? fi !# @@ -44,63 +44,43 @@ fi ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -#! -Run with Guile-1.8: -GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' scripts/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 pretty-print) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) + #:use-module (mes misc) + #:use-module (mescc mescc) #:export (main)) (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "MES_PREFIX") "") "@PREFIX@")) +(define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" + "@VERSION@")) + (cond-expand (mes - (define %scheme "mes") - (define (set-port-encoding! port encoding) #t)) - (guile-2 - (define %scheme "guile") - (define-macro (mes-use-module . rest) #t) - (module-define! (resolve-module '(language c99 compiler)) '%prefix %prefix)) + (define (set-port-encoding! port encoding) #t) + (mes-use-module (mes guile)) + (mes-use-module (mes misc)) + (mes-use-module (mes getopt-long)) + (mes-use-module (mes display)) + (mes-use-module (mescc mescc))) (guile - (use-modules (ice-9 syncase)) - (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)) + (define-macro (mes-use-module . rest) #t))) (format (current-error-port) "mescc[~a]...\n" %scheme) (define (parse-opts args) (let* ((option-spec - '((c (single-char #\c)) + '((assemble (single-char #\c)) + (compile (single-char #\S)) (define (single-char #\D) (value #t)) - (E (single-char #\E)) - (g (single-char #\g)) + (debug-info (single-char #\g)) (help (single-char #\h)) (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)) + (verbose (single-char #\v)) (write (single-char #\w) (value #t)))) (options (getopt-long args option-spec)) (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?) (format (or (and usage? (current-error-port)) (current-output-port)) "\ Usage: mescc [OPTION]... FILE... - -c compile and assemble, but do not link - -D DEFINE define DEFINE + -c preprocess, compile and assemble only; do not link + -D DEFINE[=VALUE] define DEFINE [VALUE=1] -E preprocess only; do not compile, assemble or link -g add debug info [GDB, objdump] TODO: hex2 footer -h, --help display this help and exit -I DIR append DIR to include path + -l LIBNAME link with LIBNAME -o FILE write output to FILE + -S preprocess and compile only; do not assemble or link -v, --version display version and exit -w,--write=TYPE dump Nyacc AST using TYPE {pretty-print,write} @@ -132,76 +114,18 @@ Environment variables: (exit (or (and usage? 2) 0))) 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) (let* ((options (parse-opts args)) - (files (option-ref options '() '())) - (file (car files)) - (file-name (car (string-split (basename file) #\.))) - (preprocess? (option-ref options 'E #f)) - (compile? (option-ref options 'c #f)) - (debug-info? (option-ref options 'g #f)) - (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") + (options (acons 'prefix %prefix options)) + (preprocess? (option-ref options 'preprocess #f)) + (compile? (option-ref options 'compile #f)) + (assemble? (option-ref options 'assemble #f)) + (verbose? (option-ref options 'verbose (getenv "MES_DEBUG")))) + (when verbose? (setenv "NYACC_TRACE" "yes") - (format (current-error-port) "options=~s\n" options) - (format (current-error-port) "output: ~a\n" out)) - (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files)) - (with-output-to-file out - (lambda () - (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)))))))))) + (format (current-error-port) "options=~s\n" options)) + (cond (preprocess? (mescc:preprocess options)) + (compile? (mescc:compile options)) + (assemble? (mescc:assemble options)) + (else (mescc:link options))))) 'done